Script談話室バックナンバー2011

Re:頂点のxy座標をすべて取得したい    与太郎
Fri Dec 23 9:41:02 2011

はじめまして、
下のスクリプトは選択した直線、四角形、多角形、曲線、基準点の座標を
'Output File'(または'Output.txt')に書き出します。
タブ区切りテキストなので、表計算などにコピペして使えます。
グループ内やシンボル内は処理しません。
選択図形以外やグループ内まで探したい場合はForEach...のパラメータを変えます。
別の種類の図形も処理したい場合は、caseループ内に追加します。
それから、「__」はタブかスペースに置き換えないと実行出来ません。

procedure test;
{$ DEBUG}
const
__TB = Chr(9);
__SelectedObjects = 2;
__TraverseShallow = 0;
__EditableLayers = 4;

function GetVertexes(h:handle):boolean;
const
__LineObj = 2;
__RectObj = 3;
__PolyObj = 5;
__LocusObj = 17;
__CurveObj = 21;
var
__tp, id, n__:integer;
__x, y__:real;
__
__procedure WriteVertex(h:handle; tp, i:integer; x, y:real);
__begin
____Write(h); Tab(1);
____Write(tp); Tab(1);
____Write(i); Tab(1);
____Write(x); Tab(1);
____WriteLn(y);
____Message(h, '(', tp, '): ', i, ': ', x, ', ', y);
__end;{WriteVertex}
__
begin{GetVertexes}
__tp:= GetType(h);
__case tp of
____LineObj: begin
______n:= 2;
____end;{LineObj}
____RectObj: begin
______n:= 4;
____end;{RectObj}
____PolyObj, CurveObj: begin
______n:= GetVertNum(h);
____end;{PolyObj, CurveObj}
____LocusObj: begin
______n:= 1;
____end;{LocusObj}
__end;{case}
__for id:= 1 to n do begin
____Get2DPt(h, id, x, y);
____WriteVertex(h, tp, id, x, y);
__end;{for}
__GetVertexes:= false;
end;{GetVertexes}

begin{test}
__WriteLn('Hdl', TB, 'Tp', TB, 'Pt#', TB, 'X', TB, 'Y');
__ForEachObjectInLayer(GetVertexes, SelectedObjects, TraverseShallow, EditableLayers);
__ClrMessage;
end;
Run(test);

ファイルをVectorScript形式で書き出すという手もあります。
数字を抜き出すのに手間がかかりますけど。


頂点のxy座標をすべて取得したい    script 初心者です
Fri Dec 23 4:42:28 2011

はじめまして。いきなりの質問ですみません。
vectorworksで描いた図形の、すべての頂点のxy座標を書き出したいのですが
方法がわかりません。
直線で描かれた図形に関しては座標が取れたのですが、曲線の頂点の座標も含めてすべての頂点を書き出したいのです。
よいscriptがありましたらぜひ教えてください。。。よろしくお願いします。


RE6: プラグインオブジェクトの作り方2   hyodo
Sat Nov 12 23:16:26 2011

おかげ様で、以前から作ってみたかった平面図用のドアプラグインが出来ました。
フラッシュドア、ガラス框ドア、単線ドアを描くことができます。

{*******************************************************************************
Door_2D
平面図用ドア__2点型オブジェクト __
*******************************************************************************}
PROCEDURE Door_2D;
VAR
objName,dLwStr :STRING; {GCOI で使う変数}
objHand, recHand, wallHand :HANDLE; {GCOI で使うハンドル}
hhTra:ARRAY[1..3] OF Handle; {ドア軌跡、框ドア見掛りラインのハンドル}
dw, dt, da, dst :REAL; {ドア幅、ドア厚、開き角度、框見附}
dLs, dLw :INTEGER; {軌跡の線の種類・線の太さ}
dHinge :BOOLEAN; {吊元反転(チェック時反転)}

{//////////////////////////// Door2D //////////////////////////////}
PROCEDURE Door2D;
BEGIN
If dt=0 Then Begin {ドア厚 0 のときの処理}
Line(dw, 0); {ドア}
Move(-dw, 0); {ペンの位置を戻す}
End
Else Begin {ドア厚 0 以外のときの処理}
if dst=0 then begin {フラッシュドアのときの処理}
Rect(0, 0, dw, -dt); {フラッシュドア}
end
else begin {框ドアのときの処理}
Rect(dst, 0, dw-dst, -dt); {框と框の間}
hhTra[3]:=LNewObj;
Rect(0, 0, dst, -dt); {框吊元}
Rect(dw-dst, 0, dw, -dt); {框錠側}
Move(dst, -dt/2); {ペンをガラス位置に移動}
Line( dw-2*dst, 0 ); {ガラス}
Move(-dw+dst, dt/2); {ペンの位置を戻す}
end;
End;
If Not dHinge Then Begin {ドア軌跡の処理}
Line( dw*Cos(Deg2Rad(da)), dw*Sin(Deg2Rad(da)) );{ドア開き}
hhTra[1]:=LNewObj;
ArcByCenter( 0, 0, dw, 0, da ); {ドア軌跡}
hhTra[2]:=LNewObj;
End
Else Begin {ドア吊元反転の処理}
Move(dw, 0); {吊元へ移動}
Line( -dw*Cos(Deg2Rad(da)), dw*Sin(Deg2Rad(da)) );{ドア開き}
hhTra[1]:=LNewObj;
ArcByCenter( dw, 0, dw, 180-da, da );{ドア軌跡}
hhTra[2]:=LNewObj;
End;
SetLS (hhTra[1],dLs); {線の種類をSET}
SetLW (hhTra[1],dLw); {線の太さをSET}
SetFPat (hhTra[2],0); {模様をなしにSET}
SetLS (hhTra[2],dLs); {線の種類をSET}
SetLW (hhTra[2],dLw); {線の太さをSET}
SetFPat (hhTra[3],1); {面をSET}
SetLW (hhTra[3],1); {線の太さをSET}
END;

{////////////////////////////////// MAIN ///////////////////////////////////////}
BEGIN
dw := Abs(PLINELENGTH); {ドア幅 Dimentsion 100(Metric)}
dt := Abs(PDT); {ドア厚 Number 30}
da := Abs(PDA); {開き角度 Number 80}
If Abs(PDST) <= dw/2 Then dst:= PDST Else dst:=dw/2; {框ドアの見附。0 の時はフラッシュとする。 Number 0}
dLs:= PDLS; {ドアの軌跡の線種}
dLwStr:= PDLW; {ドアの軌跡の線の太さ >> ダイアログで渡す。1=1/16, 4=5/16, 8=1/2}
dLw:=Str2Num(dLwStr); {プルダウンを使ってみたかったので試してみる}
dHinge := PDHINGE; {吊元反転 Boolean False}
If GetCustomObjectInfo( objName, objHand, recHand, wallHand ) Then Door2D;
If dt=0 Then EnableParameter(objHand, 'DST', False);{ドア厚 0 の時に框見附フィールド入力不可}
END;
Run( Door_2D );


RE5: プラグインオブジェクトの作り方2   hyodo
Fri Nov 11 17:21:20 2011

石男さん、教えていただいた方法で2Dでも扉がスライドしました。

石男さんのスクリプトを参考に、簡単な2Dの開きドアのプラグインオブジェクトを作ってみました。負の値のときの処理とか、線種や面の属性パラメータまでは作り込んでいませんが、プラグインオブジェクトを作るきっかけになってよかったです。

2点型オブジェクトとして作ったのですが、2点間をドア幅とするように設定しました。
自動的に作成されるパラメータ "LineLength" は予約語のようですね。


{ 2点型オブジェクト }
PROCEDURE SampleDoor2;
VAR
objHand, recHand, wallHand : HANDLE;
objName : STRING;
dw, dt, da : REAL;

{////////////////////////////// Door2D ////////////////////////////}
PROCEDURE Door2D;
BEGIN
If dt=0 Then Begin {ドア厚 0 のときの処理}
Line( dw, 0 );{ドア}
Move( -dw, 0 );{ペンの位置を戻す}
Line( dw*Cos(Deg2Rad(da) ), dw*Sin(Deg2Rad(da)) );{ドア開き}
End
Else Begin {ドア厚 0 以外のときの処理}
Rect( 0, -dt, dw, 0 );{ドア}
Line( dw*Cos(Deg2Rad(da) ), dw*Sin(Deg2Rad(da)) );{ドア開き}
End;
ArcByCenter( 0, 0, dw, 0, da );{ドア軌跡}
END;

{//////////////////////////////////MAIN///////////////////////////////////////}
BEGIN
dw := PLINELENGTH{ドア幅 Dimentsion 100(Metric)};
dt := PDT{ドア厚 Number 30};
da := PDA{開き角度 Number 80};

IF GetCustomObjectInfo( objName, objHand, recHand, wallHand ) THEN Door2D;

END;
Run( SampleDoor2 );


RE4: プラグインオブジェクトの作り方2    石男
Thu Nov 10 12:28:07 2011

動いて良かったです。
2Dの場合もサブルーチンで目的の図形のハンドルを渡せるようにして、
メインルーチンでHMoveで動くようにすれば、大丈夫です。

PROCEDURE Door2D( VAR objH : HANDLE);
BEGIN
Rect( 0, d, w, 0 );{下枠}
Rect( -t, d, 0, 0 );{左枠}
Rect( w, d, w+t, 0 );{右枠}
Rect( w/2, d_t+10, w/2+d_w, 10 );{ドア}
objH := LNewObj;{開閉させる為にドアのハンドルを取得}
END;

メイン部分...

Door2D( door2 );
IF onoff THEN HMove( door2, -w/2, 0 );
こんな感じで、例えば扉にガラスが入っていれば、ガラス毎グループ図形にして
そのハンドルを渡すとかすれば、動きます。


RE3: プラグインオブジェクトの作り方2   hyodo
Thu Nov 10 8:42:42 2011

石男さま、

2Dで見ていました。

3Dにして扉のスライドを確認しました。

ありがとうございます。


RE2: プラグインオブジェクトの作り方2    石男
Wed Nov 9 21:10:03 2011

>名前: BOOL
>フィールド名:ドアの開閉
>型:Boolean
>初期値:False

パラメータの設定は間違っていません。このサンプルは、単に扉がスライドするだけの
もので...しかも、3次元表示の場合です。2次元は何も起こりません。
90度開閉のサンプル作るの面倒で...、考え方を分かっていただきたく。


RE1: プラグインオブジェクトの作り方2   hyodo
Wed Nov 9 18:59:12 2011

初めての書込みです。
Vectorworks は10年くらい使用していますが、
昨年、3月より急に VectorScript に目覚めまして、
Script談話室の過去の投稿を拝読し勉強しました。
どうぞよろしくお願いします。

石男さま、

プラグインオブジェクトは、以前から作ってみたかったのですが、スクリプトを拝見しまして大変参考になりました。ありがとうございます。

ちょっと教えていただきたいのですが、
パラメータの

onoff := PBOOL{パラメータ型Boolean false};

の部分ですが、
VWのメニューの「プラグインコマンド編集」ダイアログの「パラメータ」ボタンをクリックして、設定するのですよね。

名前: BOOL
フィールド名:ドアの開閉
型:Boolean
初期値:False

で設定したのですが、ドアが開閉しません。
何が問題なのでしょうか?(私がフィールドフォーマットを理解していないだけなのかもしれませんが・・・)教えていただけませんか?

どうぞよろしくお願いいたします。


VectorScript_談話室の文字列表示    管理人
Tue Nov 1 13:35:01 2011

常連さんには、そこからかい!ではありますが…高校情報処理Aのつもりで。

当クラブの談話室の仕組みが原因で、書込み通りに表示されない場合があります。
本文の記入欄は、ご覧の通り、長文を書き込むには狭すぎます。
最新のブラウザなら、フィールド右下をドラッグして拡げられますが、
それでも、超長文となると、書き込み易いとは言えません。

特に、VectorScript、すなわち、プログラムとなると、正確さが重要。
一文字の書き間違えで、エラーや誤動作になるので、慎重な校正が必要です。
つまり、回答者の皆さんは、読み返したり手直ししたり、大変な手間なのです。

これらの繁雑な作業を、談話室のフィールドで行うのは、効率が悪いです。
そこで、別のソフトで文章を作成します。
文字には装飾など不要なので、単機能、動作高速のエディタなどが便利です。
Windowsユーザーなら、アクセサリーにあるメモ帳がエディタに相当します。
同じくアクセサリーのワードパッドは、簡易でもワープロといえる性能です。

さて、メモ帳のデータは、単純なテキストデータとして保存されます。
単純なので、Windowsのどのソフトでも扱えます。
ワードパッドはリッチテキスト形式でデータを保存できるので、やや心配。

また、メモ帳でも、機種依存文字を使うと、トラブルの元。
丸で囲んだ数字とか、小さな一文字分サイズの、株式とか単位の記号などです。
これ等は、他のOSやソフトでは文字化けする可能性があります。

ところで、VectorWorksにもScript作成のためのエディタが搭載されています。
短かいプログラムなら、ここに直接書き込んで、実行テストも手軽です。
下記で、石男さんが「動きます」と書かれたのは、こうして確認済みの意味かと。
ここに書いたプログラム文をコピーして、直接、談話室にペーストできます。
でも、プログラム以外の解説文もありますから、多分、エディタを経由かと。

実際は、VectorScriptのエディタと使い慣れた別のエディタを行ったり来たり。
実行テストして、不都合をエディタで直し、VectorScriptエディタにペースト。
実用のScriptはロックをかけますから、別のエディタのファイルを残します。

完成した、解説文付きのScriptを談話室にペーストするわけですが、
ここで、ペーストした文章が文字化けしていないか、確認の要ありです。
でも、本当のところは、送信した結果を見ないと分かりません。
そこで、必要なら、修正して再送信ということに。
本当に、回答者の皆さんは大変な手間をかけ、しかもボランティアなのです。

つづく…。


プラグインオブジェクトの作り方2    石男
Mon Oct 31 17:56:34 2011

ツールとメニュならテキストファイルで試行錯誤が出来るのでですが、プラグインオブジェ
クトは一度、VW上でプラグインそのものを作らないとテストが出来ません。
これが非常に面倒な原因なんですが、このような仕様なので仕方がありません。

最終的にこんな感じにまとめて作ります...
{ 1点型オブジェクト }
PROCEDURE SampleDoor;
VAR
objHand, recHand, wallHand : HANDLE;
objName : STRING;
w, h, d, t, d_w, d_t : REAL;
door : HANDLE;
onoff : BOOLEAN;
{////////////////////////////// Door2D ////////////////////////////}
PROCEDURE Door2D;
BEGIN
Rect( 0, d, w, 0 );{下枠}
Rect( -t, d, 0, 0 );{左枠}
Rect( w, d, w+t, 0 );{右枠}
Rect( w/2, d_t+10, w/2+d_w, 10 );{ドア}
END;
{////////////////////////////// Door3D ////////////////////////////}
PROCEDURE Door3D( VAR objH : HANDLE);
BEGIN
BeginXtrd( -t, 0 );
Rect( 0, d, w, 0 );{下枠}
EndXtrd;
BeginXTrd( -t, h );
Rect( -t, d, 0, 0 );{左枠}
EndXtrd;
BeginXtrd( -t, h );
Rect( w, d, w+t, 0 );{右枠}
EndXtrd;
BeginXtrd( h, h+t );
Rect( -t, d, w+t, 0 );{上枠}
EndXtrd;
BeginXtrd( 0, h );
Rect( w/2, d_t+10, w/2+d_w, 10 );{ドア}
EndXtrd;
objH := LNewObj;{開閉させる為にドアのハンドルを取得}
END;

{//////////////////////////////////MAIN///////////////////////////////////////}
BEGIN
w := PW{パラメータ型Number 1800};
h := PH{パラメータ型Number 2100};
d := PD{パラメータ型Number 60};
t := PT{パラメータ型Number 30};
d_w := w/2;
d_t := PD_T{パラメータ型Number 40};
onoff := PBOOL{パラメータ型Boolean false};

IF GetCustomObjectInfo( objName, objHand, recHand, wallHand ) THEN BEGIN
Door2D;

Door3D( door );
IF onoff THEN Move3DObj( door, -w/2, 0, 0 );
END;
END;
Run( SampleDoor );

一応、動きます...


プラグインオブジェクトの作り方    石男
Mon Oct 31 17:48:32 2011

プラグインオブジェクトは一番作るのが面倒ですので、作業手順としては
まず、作図部分を分けて作ります。これを完璧にした上でプラグインオブジェクトの
プログラムを仕上げます。

例えばこんな感じに...
PROCEDURE Door2D;
VAR
w, h, d, t, d_w, d_t : REAL;
BEGIN
w := 1800;
h := 2100;
d := 60;
t := 30;
d_w := w/2;
d_t := 40;

Rect( 0, d, w, 0 );{下枠}
Rect( -t, d, 0, 0 );{左枠}
Rect( w, d, w+t, 0 );{右枠}
Rect( w/2, d_t+10, w/2+d_w, 10 );{ドア}
END;
RUN( Door2D );


RE65:重なった直線の検出と処理    与太郎
Tue Aug 9 10:46:44 2011

誤差を許した場合、無駄なチェックを避けつつ完全に重複図形を無くすのは無理なのかも知れません。
2本の直線の角度の差が大きくても、長さが十分短ければ誤差の範囲内に収まってしまう場合もあるでしょう。
だから、座標の許容誤差が○○のとき角度の差が○○以上なら絶対に重ならないとは言い切れません。
結局のところ今のやり方だと、角度の許容誤差を調整して実行時間を短くする代わりに少量のチェック漏れを許すか、逆に時間をかけてチェック漏れを減らすかを選択することになります。
そんなことを考えてるうちに書き込みが止まってしまいました。

次回の書き込みで打ち止めにしたいと思います。


RE64:重なった直線の検出と処理    管理人
Fri Jul 29 15:24:49 2011

与太郎さんのScript更新の追加部分を連載コラムに追加しました。
与太郎さん、丁寧な解説やアルゴリズムの紹介をありがとうございます。

さらに、お願いごとで恐縮ですが、お時間のあるときに、
前回と同じ形式で、更新分のScriptを納めた、別名のフォルダを送って頂けると有り難いです。
前回のリンク画像に並べて、No2とでも名付けてリンクしたいと思います。
ご検討いただけると幸いです。


引越しました    管理人
Fri Jul 29 15:15:05 2011

これまでの書き込みはバックナンバーに送りました。
ご了承下さい。


業務連絡    管理人
Wed Jul 27 10:15:53 2011

お気付きと思いますが、
プログラムによる会議室荒らしを受けています。
対策として引越しを予定しています。

引越した場合は、トップページから入り直して下さい。
お手数をおかけします。よろしくお願いいたします。


RE63:重なった直線の検出と処理    与太郎
Mon Jul 11 11:15:25 2011

2次元配列では添字は2つで1組なので、まとめて構造体にします。
そのほうが代入文が1つで済むからです。
しかし配列にアクセスするには、やはり line[index.H, index.L] のように書く必要があり
ます。
Change手続きの中にはline[i.H, i.L]とline[j.H, j.L]が何度も出てくるので、
var lnI, lnJ で変数パラメータにすれば簡潔だし、配列の添字の書き間違いもなく無くな
ると考えました。
ところが実行すると、エラーでVWが終了してしまうのです。
コンパイルは出来ても実行時にエラーが出ることが、VectorScriptではたまにあります。
デバッグ・モードで実行してもVWが突然落ちてしまうので、問題箇所を特定するのが一
苦労です。
ブレークポイントを変えながら何度もVWの再起動を繰り返して、Check手続きの中に該
当箇所を見つけました。
それは、nxt:= lnJ.next; と prv:= lnJ.prev; の2文でした。
以前は nxt:= line[j.H, j.L].next; prv:= line[j.H, j.L].prev; のように書いていましたが、
[ ]の中に j を2つ書くのを嫌って直した部分です。
他にもline[j.H, j.L]をlnJに書き換えた所はあるのに、何故そこだけが問題なのか、
本当のところはは分かりませんが、
多分それが構造体の中の構造体だということと関係はあるのでしょう。
ネイティブ・コンパイラなら問題無い方法だと思いますが、VectorScriptは中間コードに
変換する方式のはずなので、その辺の制限があるのでしょう。
ここでは原因は追求せず、対処療法にとどめておきます。
エラー回避の方法は2つあります。
1つ目は、nextとprevを一度に代入せずに、nxt.H:= lnJ.next.H; nxt.L:= inJ.next.L; と、
メンバ単位で代入する方法。
2つ目は、修正前の nxt:= line[j.H, j.L].next; prv:= line[j.H, j.L].prev; です。
せっかく定義した変数パラメータlnI, lnJを使わないのはもったいないのですが、結局は
命令数が2つで済む2つ目の方法を採りました。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_6c.htm

前回までは SbscriptType のメンバ名は up, lw でしたが、今回 H, L に変更しました。
upに対応するのはdown、lowに対応するのはhighなので、以前から直したいと思ってい
たところです。
高次(H)と低次(L)のほうが意味が合っています。


RE62:重なった直線の検出と処理    与太郎
Thu Jul 7 12:41:03 2011

line[j]の直線を削除する手順を考えます。
j = 10 のとき、前後のデータが以下のようになっていたと仮定します。

line[ 8].next =  9  line[ 8].prev =  7
line[ 9].next = 10  line[ 9].prev =  8
line[10].next = 11  line[10].prev =  9
line[11].next = 12  line[11].prev = 10
line[12].next = 13  line[12].prev = 11

nextは順方向リンクのポインタ、prexは逆方向リンクのポインタです。
ここからline[j](line[10])の線を削除する手順は、
DelObj(line[j].h); line[j].h:= nil;
となります。
循環リストからline[10]を取り除くには、
line[9].nextとline[11].prevの値を変えて下のようにします。

line[ 8].next =  9  line[ 8].prev =  7
line[ 9].next = 11  line[ 9].prev =  8
line[10].next =(11)  line[10].prev = (9) {削除データ}
line[11].next = 12  line[11].prev =  9
line[12].next = 13  line[12].prev = 11

これで順方向、逆方向ともにline[10]のデータはスキップされるので、
配列の再ソートやif文などは不要になります。
間違えてline[10]にアクセスしても処理を続けられるように、
line[10].nextとline[10].prevはゼロクリアはしないで、そのままにしておきます。

具体的には以下のようなスクリプトになります。

prv:= line[j].prev; {prv = 9}
nxt:= line[j].next; {nxt = 11}
line[prv].next:= nxt; {line[9].next = 11}
line[nxt].prev:= prv; {line[11].prev = 9}

上記の処理は、全てCheck手続きの中で行います。
以下は、line[i]に対して、角度の増加方向と減少方向の両方をチェックするスクリプトです。
line[i]の角度が変化したときは最初からやり直しますが、リストの順番は変えません。
重複チェックの取りこぼしには、角度の許容誤差を大きめにして対処します。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_3g.htm

2次元配列版はバグ取り中です。


RE61:重なった直線の検出と処理    与太郎
Thu Jun 23 11:08:00 2011

RE:59の続きです。
最後のスクリプトの3行目の j:= i + 1; は j:= line[i].next; が正しいので、下のように
なります。

for i:= 1 to n do begin
  if line[i].h <> nil then begin
    j:= line[i].next; {j:= i + 1;}
    while (line[j] <> nil) & (i <> j) & (Abs(line[j].ang - line[i].ang) <= AngPrec) do begin
      Check(i, j); { 重複チェック処理 }
      j:= line[j].next; { j:= i + 1; }
    end;
  end;
end;

いきなりですが、ここからはポインタのおはなしです。
CやPascalの変数型には、変数の位置を表すポインタ型があります。
ポインタ型は、たいていは変数のメモリアドレスで、内部的には長整数型です。
元々CPUの動作にメモリアドレスは欠かせません。
マシン語や、それを読みやすく記述したアセンブリ言語でもそれは変わりません。
しかしメモリアドレスの計算は面倒だし、実行時でないと決まらないことも多いので、
メモリアドレスに名前を付けて、アドレス計算はコンピュータに任せることにしました。
これが変数の始まりです。
変数の割当て(CPU内部のレジスタかメインメモリか)や、ループや分岐のラベル生成を
自動的にやってくれれば、それはもう立派な高級言語です。
というわけで、高級言語ではメモリアドレスなどは考える必要はなくなったはずでした。
しかし「変数の位置」はプログラムに有用なこともあって、CやPascalではポインタ型が
導入されています。
ただしPascalでは「変数の位置」は隠蔽されていて、ポインタの値は不明です。
可能な演算も比較と代入のみです。
参照先のの変数型が違うポインタ同士は違う変数型になるので、演算は許されません。
プログラミングの自由度や実行速度が優先のC言語では、ポインタは参照先の変数型と関係
ないメモリアドレスで、長整数型と同等として扱われるので演算にも制限はありません。
そのためポインタを使えば何でも出来るという反面、思わぬ落とし穴もあります。

VectorScriptはPascal準拠のスクリプト言語ですが、ポインタ型はありません。
前身のMiniPascal開発時に、マクロ(スクリプト)言語へのポインタ型導入はメリットより
デメリットのほうが大きいと判断されてしまったのでしょう。
VectorScriptのハンドル型の実体はポインタそのものですが、対象は図形とリソースのデー
タに限定されています。
(ハンドル変数への演算もPascalのポインタ同様、比較と代入以外は許されていません。)
だからといって、VectorScriptで変数へのポインタを使ったスクリプトが書けないわけでは
ありません。
MiniPascalの開発者からは否定されましたが、当時はデバッガもないので無理ありません。
しかし今では(非力ながら)デバッガのおかげで、実行中の変数の値を確認出来ます。
よほど複雑怪奇なことをでなければ、ポインタを使ったスクリプトも可能でしょう。
実際、LineType構造体のnext項目のデータはメモリアドレスではなく配列内の番号ですが、
ポインタとして機能します。
元々Pascalのポインタは、メモリアドレスを指すと決まっているわけではなく、そうなって
いるのはコンパイラ実装の都合に過ぎません。
変数を番号で管理しても構わないのです。
というわけで、line変数は外側のforループでは配列として、内側のwhileループではポイン
タで連結された循環リストとして扱っています。

ところで、合成後の角度が変わらない場合でも、データの順番によっては重複チェックの漏
れが起こります。
たとえば、1本の線を3分割してA, B, C とした場合、AとB、またはBとCは繋がりま
すが、AとCは離れているので繋がりません。
もしもA, C, Bの順になっていたら、
まず、line[i]=A, line[j]=Cでは重複はしません。
次の、line[i]=A, line[j]=BでAとBが合成されてAに反映され、Bが削除されます。
そうするとこの時点でCは合成後のAと比較される機会が無くなります。
元のデータは順番通り並んでいても、ソート後はどんな順番になっているか判りません。
そういう意味では、line[i]を削除してline[j]を変形したほうが良かったのです。
あくまでも「合成後に角度が変わらない場合は」ですが。

しかし合成して角度が変わると、直線が角度順に並んでいるという前提が崩れてしまいます。
どちらを削除してどちらを変形するという問題だけではなくなります。
それでは配列のそのデータの付近だけでも再ソートするとどうなるでしょうか。
ちょっと考えても、チェック済みと未チェックの直線がごっちゃになってしまいそうです。
最悪は、iループでチェック済みの直線を何度もチェックするということになりそうです。
そもそも、forループでは出来そうもありません。
外側のiループでは全ての直線を重複や漏れなくチェックしたいので、出来るなら単純なfor
ループでやりたいです。
となると、配列の再ソートは出来ません。

で。よく考えたら外側のiループは角度順になっている必要はないのでした。
角度順で処理したいのは内側のjループのほうです。
だから配列のほうは放っておいて構わないということです。
では、内側のjループのほうは、対処法はふたつ考えられます。
1つ目の方法は、角度の許容誤差より広い範囲の角度までチェックすることです。
具体的には、AngPrecの値を大きめに設定します。
合成後の角度がよほど違わない限り、これで大丈夫だと思います。
余計な角度チェックの分だけ実行時間は増えますが、楽な方法です。
もうひとつは、nextの値を変えて、循環リストの順番を角度順に修正する方法です。
後者が正しいやり方だとは思いますが、どちらが速いのか確信は持てません。

どちらにしても、nextの他にprevという項目も付け加えて、line[i]に対して角度の増加側
と減少側の両方をチェックしたほうが良いのは確かです。
また、合成後の角度が変わったことを表す変数changeを追加して、角度が変わったらループ
を終了して最初からやり直すように変更します。
直線の削除と合成、循環ループの修正などの処理は、Check手続きの中で行います。

for i:= 1 to n do begin
  if line[i].h <> nil then begin
    change:= true;
    while change do begin
      change:= false;
      j:= line[i].next;
      while (i <> j) & (Abs(line[j].ang - line[i].ang) <= AngPrec) & (not change) do begin
        Check(i, j, change); { 重複チェック処理 }
        j:= line[j].next;
      end;
      if not change then begin
        j:= line[i].prev;
        while (i <> j) & (Abs(line[j].ang - line[i].ang) <= AngPrec) & (not change) do begin
          Check(i, j, change); { 重複チェック処理 }
          j:= line[j].prev;
        end;
      end;
    end;
  end;
end;

削除したデータはnext, prevの値を変えて循環リストから取り除けばいいので、whileの条件
の「line[j] <> nil(本当はline[j].h <> nil)」は消しました。


RE60:重なった直線の検出と処理    与太郎
Mon Jun 20 13:58:46 2011

Ver.3eとVer.6aのGetUnion手続きが間違っていました。
改造時にバグが紛れ込ませたようです。
pt31とpt32を計算しないといけないのに両方ともpt31になっていて、
pt32は常に(0, 0, 0)を返していました。

procedure GetUnion(pt11, pt12, pt21, pt22:vector; var pt31, pt32:vector);
{ pt11〜pt12とpt21〜pt22の両方の直線を合成して返す。 }
begin
__pt31:= If_V(pt11.x < pt21.x, pt11, pt21);
__pt32:= If_V(pt12.x < pt22.x, pt22, pt12);
end;{GetUnion}

http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_3f.htm
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_6b.htm


RE59:重なった直線の検出と処理    与太郎
Fri Jun 17 15:58:13 2011

その場しのぎで最適化してきたため、改造するのが面倒になってきました。
ここらで一度、最初から整理してみたいと思います。

直線の重複チェックの処理は、
2本の直線を重複チェックするサブルーチンと、そのサブルーチンを呼び出す部分から成ります。
仮に重複チェックのサブルーチンをCheck手続きとしておきます。
この手続きは、直線データの配列の番号を2つ受け取り、重なっているかチェックして、
重なっていれば直線を合成し、不要な線を削除します。

直線データの配列変数lineのデータ型は、下のような構造体です。

LineType = structure
   ang :real;
   ptSt, ptEd :vector;
   h :handle;
end;

angは、0〜180°の範囲に調整した直線の角度です。
ptStとptEdは、直線の端点の座標です。
hは、直線図形のハンドルです。直線を削除したらnilを入れます。
ang, ptSt, ptEdは、ループ内で何度も情報を取得する無駄を省くための項目です。

Check手続きを呼び出す部分は、一番単純な方法では2重ループで全ての組合わせを実行します。
配列の範囲が[1..n]とすると、スクリプトは下のようになります。
話を単純にするため、線の属性や配列サイズの制限は無視しています。

for i:= 1 to n-1 do begin
   if line[i].h <> nil then begin
      for j:= i+1 to n do begin
         if line[j].h <> nil then begin
            Check(i, j); { 重複チェック処理 }
         end;
      ebd;
   end;
end;

線が少ないときはこれで問題無いのですが、何千本何万本とある場合は時間がかかり過ぎるので、
最初から必要が無い比較は行わないように工夫します。
たとえば、角度が大きく違う直線同士は重ならないと考えて間違いないでしょう。
逆に言えば、角度が近いものだけ比較すれば良いことになります。
そのための方法は、直線の配列を角度順に並べ換えることです。
スクリプトの高速化と単純化のため、構造体LineTypeにnextという項目を追加します。

LineType = structure
   ang :real;
   ptSt, ptEd :vector;
   h :handle;
   next :longint;
end;

nextには次のデータの番号(配列の添字)が入ります。line[i].next = i+1 です。
ただし最後だけ line[n].next = 1 とすることで、スクリプトを簡単にする効果があります。
つまり、次のデータの番号を j:= j + 1; で計算すると、最後のデータでjが配列の範囲外になるため
if n < j then j:= 1; で最初に戻す必要がありますが、j:= line[j].next; だと勝手に戻ります。
その代償は余分なメモリと余分な前処理のサブルーチンですが、それだけの価値はあります。

AngPrecを角度の許容誤差とすれば、角度でソート済みの配列に対しての処理は下のようになります。

for i:= 1 to n do begin
   if line[i].h <> nil then begin
      j:= i + 1;
      while (line[j] <> nil) & (i <> j) & (Abs(line[j].ang - line[i].ang) <= AngPrec) do begin
         Check(i, j); { 重複チェック処理 }
         j:= line[j].next;
      end;
   end;
end;

外側のforループは一本分だけ増えます。
内側のwhileループの条件判定で、角度の差がAngPrecより大きくなったらループを終了してcheck手続き
の実行回数を減らすことで、実行時間を短縮しています。

ここまでが現在の状況です。
これからの課題は、線を合成して角度が変わってしまったときの対処法です。
このままでは、線が重なっているのにチェックされないケースが生じます。


Re:業務連絡    与太郎
Fri Jun 17 15:55:58 2011

>管理人さん
ありがとうございました。


業務連絡    管理人
Fri Jun 17 14:50:06 2011

与太郎さんの御依頼で書き込み修正しました。
お手数ですが、凄い展開なので、引き続き、よろしくお願いいたします。



RE55:重なった直線の検出と処理    管理人
Thu Jun 9 7:07:59 2011

このテーマ、連載コラムにまとめました。
作成過程のScriptもご覧頂ける様にして下さいましたので、
是非ご一読下さい。ノウハウ満載の大作です。
参加された猛者連に改めて感謝!
ありがとうございます。


RE54:重なった直線の検出と処理    与太郎
Tue May 31 13:13:12 2011

>リンク先に有るソースですが、一段落しましたらここへ貼り付けませんか?
>少々の行数は大丈夫でしょう。
バギーな初期のバージョンから数えて12本目の最新バージョンは600行を越えています。
こんなのを何個も貼っても大丈夫でしょうか。
コメントをスクリプトではなくここに書き込んだ結果、両方見ないとバージョン間の変更点が
自分でも判らないという状態に落ち入っています。
いっそHTMLファイルを管理人さんに預けてしまいましょうか。
とりあえず、最新版のアドレスを貼っておきます。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_6.htm

更なるメモリ節約のため、
属性を別の配列にして、線のデータに入れるのは属性の番号だけにしました。
これで直線1本当り80バイト近く減らせて(計算上は)66バイトになります。
直線ハンドルの配列は、属性の番号を追加したので1本当り6バイトです。
たとえ百万本のデータでも66MB+6MBで収まる計算です。
ただ、アクティビティモニタでスクリプト実行中のメモリ使用量を見ると、
変数確保よりも図形削除による(多分Undo処理のための)メモリの増加の方が遥かに多いので、
余計な心配かも知れません。
Undoと言えば、数千本削除した後のUndoなら少々待たされるくらいで済みますが、
9万本削除後のUndoは厳禁です。(メモリを4GB以上積んでたら大丈夫なのかも知れませんが。)
実行前に必ず保存して、「取り消し」でなく「復帰」で元に戻せるようにしましょう。

データ構造が変わったので、処理の流れも変わっています。
最初にハンドルを取得する時に属性の番号を与え、属性別に本数をカウントします。
属性別の線の本数から線データ配列内での各属性の範囲が計算出来るので、
線データ配列にデータをコピーし終わった時点で、線データ配列は属性別にソートされています。
あとは属性別に角度でソートすることになります。
全てが同じ属性でない限り、ソートの範囲が狭くなるのでソート時間も短縮するはずです。
ただし属性の番号を決定するのに手間取ると、逆に時間がかかってしまいます。
レイヤ数や属性の種類が多いほど、ソート時間は短縮しますが、
1つのレイヤ内の属性の種類が多いと、属性番号を検索するのに時間がかかかって、
ソート時間の短縮が相殺される可能性もあります。
属性番号の検索は単純な線形探索です。

環境を変えて実行時間を計ってみました。
選択ソートに切り替える数は15、許容誤差は0.001、角度の許容誤差は0.001°です。
結果:172109個中 93941個削除 0個削除不能
PPC G4 1.67GHz/1.5GB VW11.5 (t=1635sec.)
Core 2 Duo 1.4GHz/2GB VW11.5 (t=1805sec.)
Core 2 Duo 1.4GHz/2GB VW12.5 (t=1940sec.)
Core 2 Duo 1.4GHz/2GB VW2009 (t= 634sec.)
Core 2 Duo 1.4GHz/2GB VW2010 (t= 680sec.)
Core 2 Duo 1.4GHz/2GB VW2011 (t= 668sec.)
Celeron 2.8GHz/512MB VW11.5 (t= 739sec.)
(選択ソートに切り替える数を15→20に変えると、739sec.→933sec.になりました。)

最初の実行後、さらに実行させました。削除数は当然ゼロになります。
結果:78168個中 28個削除 0個削除不能
PPC G4 1.67GHz/1.5GB VW11.5 (t=666sec.)
Core 2 Duo 1.4GHz/2GB VW12.5 (t=755sec.)
Core 2 Duo 1.4GHz/2GB VW2010 (t=281sec.)
Celeron 2.8GHz/512MB VW11.5 (t=281sec.)
(3番目と4番目がt=281sec.なのは偶然です。)


RE53:重なった直線の検出と処理   masafumi
Sun May 29 12:08:00 2011

>実行時間も40分台に向上しています。Celeron 2.8GB/512MB だと20分以下でした。

私の環境では 966 秒 (約 16 分)です。(^_^)v

リンク先に有るソースですが、一段落しましたらここへ貼り付けませんか?
少々の行数は大丈夫でしょう。
もし、数年後にリンクが途切れていたら、このスレは何を書いているのかわからなくなりそうです。
ご一考のほど、よろしくお願いします。


Re2:選択されたシンボル内の図形の色を変える   hilfiger
Fri May 27 17:41:59 2011

与太郎さん、本当にありがとうございます。

さっそく試してみたところ、選択したシンボルだけ色が変わりました。
問題点の改善は、頑張ってやってみたいと思います。

ご指摘通り、ForEachObjectについて、
今回初めてサブルーチンを使用したscriptに挑戦してみたばかりで、
ちゃんと理解できていませんでしたが、大変丁寧に教えて頂き、
一気に理解度が深まった気がします。

シンボル図形とシンボル定義の違いや、
よくわかっていなかったFInSymDefの使い方もよくわかりました。
本当にありがとうございました。

今後、与太郎さんの方角に足を向けて寝られませんが、
どちらに居られるのかわからないので
とりあえず北海道に頭を向けて寝たいと思います。


Re:選択されたシンボル内の図形の色を変える    与太郎
Fri May 27 16:56:52 2011


hilfigerさん、はじめまして。
ご希望のスクリプトは図形ハンドルを使わないと無理なのですが、いくつか誤解があるようです。

まず、ForEachObjectについて。
メインルーチンのForEachObjectから呼ばれるDoObject手続きが、引数SymHを使用していません。
サブルーチンに図形ハンドルを渡しても、それだけではその図形は実行対象にはなりません。
ForEachObject(DoObject2, (InSymbol));では、全ての図形が対象になってしまいます。
「InSymbol」の意味は「+シンボル内」で、シンボル内だけを対象にする検索条件は無いようです。
また、スクリプトをどの階層(グループ内やシンボル内)で実行しても、ForEachObjectは
トップレベルで実行されます。
様々な階層から選択図形を処理対象とするには、ForEachObjectInLayerのほうが向いています。

次に、シンボルの実体(シンボル図形)と登録シンボル(シンボル定義)の違いがあります。
VectorScriptではシンボル図形の図形タイプは15、シンボル定義は16になっています。
シンボル図形は他の図形と同様に図面に配置されます。内部的にはレイヤに属する図形です。
ただし普通の図形とは違って、形状や構成図形の情報は持たない参照図形です。
他の参照図形にはレイヤリンクがあります。
シンボル図形には名前、クラス、レコード、位置情報などの、データパレットに表示される情報は
ありますが、構成図形の情報はありません。
その代わりに参照先として、シンボル定義の情報を持っています。
シンボル定義は多数のシンボル図形から参照されるので、内部的にはリソースとして存在します。
ですからリソースパレットやリソースブラウザからアクセスします。
シンボル定義にアクセスするには、GetSymNameかGetSDNameでシンボル名を得て、
GetObject(シンボル名)でハンドルを取得します。
リソースには必ず名前が付いているので、シンボル名からアクセスするのが一番確実です。
シンボル定義の中の最初の図形はFInSymDefで得られます。

つまり、VectorWorksのデータはレイヤを根本としたツリー構造の図形リストと、根本は定かでは
ないが同様にツリー構造のリソースリストから成ります。
お題のスクリプトは両方にまたがるので、思ったより面倒なのです。

とりあえずDoObject手続きだけ修正すると、下のようになります。
ダイアログを出す前に画面を更新するために、ReDrawAll;を付け加えています。

Procedure InSymBlack;
__
__Procedure DoObject(SymH:handle);
__VAR
____ObjH, SDefH__:HANDLE;
____name__:STRING;
__BEGIN{DoObject}
____if GetType(SymH) = 15 then begin
______name:= GetSymName(SymH);
______SDefH:= GetObject(name);
______if SDefH <> NIL then begin
________ObjH:= FInSymDef(SDefH);
________while ObjH <> NIL do begin
__________SetPenFore(ObjH, 0, 0, 0);
__________SetPenBack(ObjH, 0, 0, 0);
__________ObjH:= NextObj(ObjH);
________end;{while}
______end;{if}
____end;{if}
__END;{DoObject}
__
BEGIN{main}
__ForEachObject(DoObject, ((T=Symbol)&(SEL=True)));
__SetTool(-240);
__ReDrawAll;
__AlrtDialog('完了しました');
END;{main}
Run(InSymBlack);

これでも一応目的に叶うはずです。
ただし、バージョンが古い場合、グループ内に入って個々の図形の属性を変える必要があります。
線が無い図形の線情報を変えようとすると警告エラーが出るかも知れません。
シンボル内のシンボルは対象外です。
また、同じシンボルを複数選択すると、同じシンボル定義に同じ処理を何度も繰り返してしいます。
しかし一番の気になるのは、編集不可能なレイヤや非表示のレイヤで選択されているシンボルや、
選択されていないグループの中で選択されているシンボルも実行対象になってしまうことです。


RE52:重なった直線の検出と処理    与太郎
Fri May 27 13:35:34 2011

2次元配列版で、配列の最後の図形がスキップされてしまうバグを直しました。
実行時間も40分台に向上しています。Celeron 2.8GB/512MB だと20分以下でした。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_4a.htm

メモリの使用量を減らそうと、ソート用文字列をstring型からarray[1..64] of char に変更したら、
ソートの結果がめちゃくちゃになってしまいました。
char型配列ではstring型と違って大小の比較が出来ないみたいなので、一旦string型の変数にコピー
して比較しています。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_5.htm


選択されたシンボル内の図形の色を変える   hilfiger
Fri May 27 12:33:05 2011

scriptをはじめて1ヶ月の初心者です。

『選択された図形のうち、シンボルを探し、そのシンボルの中の図形の色を黒にする』
というscriptを作成しているのですがうまくいきません。

現在以下のように書いているのですが、
シンボルが1つも選択されていなければ何も起こらず、
シンボルが1津でも選択されていた場合、選択されていないシンボルも、
さらにはシンボル以外の図形まで色が変わってしまいます。

どなたか、どこがおかしいのかご指摘いただけませんでしょうか?

Procedure InSymBlack;

Procedure DoObject2(ObjH:handle);
BEGIN{DoObject2}

SetPenFore(ObjH, 0, 0, 0);
SetPenBack(ObjH, 0, 0, 0);

END;{DoObject2}


Procedure DoObject(SymH:handle);
BEGIN{DoObject}

ForEachObject(DoObject2, (InSymbol));

END;{DoObject}


BEGIN{main}

ForEachObject(DoObject, ((T=Symbol)&(SEL=True)));

SetTool(-240);
AlrtDialog('完了しました');

END;{main}
Run(InSymBlack);


RE51:重なった直線の検出と処理    与太郎
Sun May 22 15:57:24 2011

>以前私が作った Script ですと約3倍の時間がかかりました。
masafumiさんのスクリプトでは、同一の線と部分的に重なる線を別々に処理しているのに対して、
私のほうは完全重複と部分重複の区別はしていません。
また、masafumiさんのほうは他の種類の図形も処理する分、余計に時間がかかるのかも知れません。

ソート用の文字列を生成する箇所、
line[i].sSort:= Concat(GetAttrsStr(line[i].attrs), ExpString(concat(Round(a/AnglePrec)), 12));
は、以下のように角度を許容誤差より1桁多くしました。
line[i].sSort:= Concat(GetAttrsStr(line[i].attrs), ExpString(concat(Round(a/AnglePrec*10)), 12));
許容誤差と同じだとソート語でも許容誤差の範囲内で角度の順位が前後しているので、
比較する線の取りこぼしが起きます。実際は2倍でいいと思いますが、10倍にしました。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_3d.htm

下は配列を2次元配列にして、図形数の制限を無くしたものです。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_4.htm
配列へのアクセスが煩雑になって、処理時間が2倍くらいになっています。
masafumiさんのデータ(直線数:172109)では、1時間少々かかります。
(Core 2 Duo 1.6GHz/2GB ロゼッタ環境にて)


RE50:重なった直線の検出と処理   masafumi
Fri May 20 21:07:24 2011

>データの御提供ありがとうございました。

どういたしまして、お役にたてば幸いです。

それにしても、処理速度が速いですね。
Windows7 i7CPU 2.8GHz メモリー4.0G のマシンで 54019 個の直線、重複部分 30245 個を削除するのに 152.5 秒でした。
以前私が作った Script ですと約3倍の時間がかかりました。おそれいりました m(_ _)m


RE49:重なった直線の検出と処理    与太郎
Fri May 20 9:52:10 2011

>masafumiさん
データの御提供ありがとうございました。

1次元配列のサイズ制限以上の大きなデータでも1度に処理出来るように改造していたら、
またまたバグを見付けてしまいました...

SortLines手続き内のGetPivotStr関数の
s:= Concat(s, Chr((Ord(Copy(s1, i, 1)) + Ord(Copy(s1, i, 1))) div 2)); ですが、
s2とするところがs1になっているので、結果はs1になってしまいます。
しかし、それでも問題ないみたいです。
実際にs1とs2の中間文字列になるように直したら、ソート中に配列範囲外へのアクセスが発生して止まります。
私が考えた文字列の比較方法が、VWが実際にやってる方法とは違ってるらしいです。
結局、元のデータがランダムに並んでいれば、leftとrightの間のどの値を使っても問題ないということです。
でも端っこのデータよりは真ん中へんのほうがいいと思うので、
pivot:= GetPivotStr(line[left].sSort, line[right].sSort); は、
pivot:= line[(left + right) div 2].sSort; に変更しました。
GetPivotStr関数は不要です。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_3c.htm


RE48:重なった直線の検出と処理   masafumi
Wed May 18 23:02:26 2011

>今まで扱った図面で、最大の直線数は何本くらいだったのでしょうか?

これまでの最高は DWG の図面ですが約 17 万個の直線です。恐ろしく重複部分が有ります。
角度も小数点以下 3 桁目で微妙に違っていたりするモノもあります。
当時(10年位前)にラスター → ベクター変換した図面を修復したもの考えられ、曲線らしく見える部分も細か
い直線の連続となっています。

実は今回これも VectorWorks に取り込んで選択個数を 65000 個以下にしたり、以上にしたり色々と試したのですが
正常に動いているのか、そうでないのか・・・実行しただけで検証する気力もなく、よくわかりませんでした。(笑)

下記にこの図面を置いておきます。宜しければダウンロードして試して見てください。
(所在や建物名等必要ないモノは削除しています)

http://www5c.biglobe.ne.jp/~masafumi/dwn.html


RE47:重なった直線の検出と処理    与太郎
Wed May 18 13:40:36 2011

変数の初期値については、今までデバッグ画面で観察した限り、
ゼロ(or Nil or Nul文字)以外になっていたことは無いのですが、
もちろん巨大な配列などは全て確認したわけではありません。
構造体を含んだ構造体の大きな配列という特殊なケースだからかも知れませんが、
マニュアルに明記されてないので、それ以外なら大丈夫とも言い切れません。
基本的に、必要な初期化(初期値の代入)はゼロであっても省略しないのですが、
量が多いので誘惑に負けてしまいました。
ほんの数秒の実行時間を惜しんで、それ以上の時間をデバッグに費やしたという
おそまつ。

ところでmasafumiさん、
今まで扱った図面で、最大の直線数は何本くらいだったのでしょうか?


RE46:重なった直線の検出と処理   masafumi
Tue May 17 0:12:12 2011

>直線の重なりをチェックするときに、
>ある一点から直線までの距離(直線から基準点までの垂線の長さ)でソートしてもいいかも知れません。

おもしろい発想ですね。

>線の角度が水平や垂直ばかりだったら、角度でソートする意味がないですから。

む〜ん、確かに・・・私の仕事(測量)では、こんな条件はほとんど有りませんので、思いつきもしませんでした。(^^;)

>レイヤや属性を無視したときの実行結果がおかしいのは、それらの変数を初期化してなかったからです。

初期化、やっぱ必要なんですねぇ・・・悩ましい・・・。



RE45:重なった直線の検出と処理    与太郎
Mon May 16 12:25:08 2011

直線の重なりをチェックするときに、
ある一点から直線までの距離(直線から基準点までの垂線の長さ)でソートしてもいいかも知れません。
線の角度が水平や垂直ばかりだったら、角度でソートする意味がないですから。

>masafumiさん
レイヤや属性を無視したときの実行結果がおかしいのは、それらの変数を初期化してなかったからです。
マニュアルのどこにも「変数の暗黙の初期値」の項目はないので、やはりPascalのお作法どおり変数の
初期化は必要みたいです。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_3b.htm


RE44:重なった直線の検出と処理    与太郎
Sun May 15 13:13:06 2011

CheckOverlap手続きのwhileループの前の j:= i + 1; も、
j:= line[i].next; に直さないといけないですね。


RE43:重なった直線の検出と処理    与太郎
Thu May 12 11:12:21 2011

CheckOverlap手続きの、
while (i <> j) & (Abs(line[j].ang-line[i].ang) <= AnglePrec) & (line[i].attrs = line[j].attrs) do begin
から (line[i].h <> nil) を抜いたのは失敗でした。
このループの中で線を削除したら、すぐにループを抜け出さないといけないので、
(line[i].h <> nil) は必要でした。
条件の2番目に & (line[i].h <> nil) を付け加えておきます。
それから、line[]の配列範囲の計算方法を少し変えました。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_2a.htm


RE42:重なった直線の検出と処理    与太郎
Wed May 11 11:25:35 2011

>masafumiさん
検証ありがとうございます。

初期状態では図形情報(レイヤ、クラス、線属性、名前、レコード)が欠落しないような設定なので、
レイヤ、クラス、線属性が異なる線どうしでは重複チェックをしません。
また、名前やレコードがある線は削除しません。
以下の定数、
  pUseLayer = true;{ レイヤ別にチェック }
  pUseClass = true;{ クラス別にチェック }
  pUseAttributes = true;{ 属性別にチェック }
  pNameCheck = true;{ 名前がある図形は削除しない }
  pRecordCheck = true;{ レコードがある図形は削除しない }
を全てFalseにすると一番緩い設定になり、端点の座標以外の情報を無視して処理します。
が、以上の仕様はまだ動作確認していません。


RE41:重なった直線の検出と処理   masafumi
Tue May 10 19:38:28 2011

こんにちは与太郎さん。

修正後のスクリプト試してみました。クラス・レイヤ他ソートしている条件が同じ時はOKみたいです。
複数のクラス・レイヤ又はクラス・レイヤが同じでも属性が違うときはうまくいきません。
(これはまだでしたかな・・・?)


RE39:重なった直線の検出と処理    与太郎
Tue May 10 11:34:05 2011

>masafumiさん
RE36のデータで実行結果がおかしくなるのは、
線の角度に180°足したり引いたりしたときに、始点と終点の座標を入れ替えるのを忘れたせいです。
そのため、GetOverlap手続きが意図通りに動いていませんでした。
「近い角度どうしでしか比較しないので不要 」とコメントアウトした部分が、実は必要だったのです。

R38の、角度が180°付近のときの処理は、LineType構造体に next :longint; を追加することで解決しました。
j:= j + 1; は、j:= line[j].next; に変えました。
関連して、重複チェック判定のIF文の、(line[i].attrs = line[j].attrs) は(消していませんが)不要になりました。
その他も色々直しています。
http://web.me.com/justlikeyoudo/vsfactory/samples/commands/check_overlap_line_2.htm


RE38:重なった直線の検出と処理    与太郎
Sun May 8 11:30:21 2011

RE35の自己レスです。

>ただ、最小値と最大値付近で余計な手間がかかってしまいますが。
とRE19で言及したのに、自分が書いたスクリプトではその部分をスルーしてました。
つまり、line[i]とline[j]を比べるときにline[i]の角度が180°-AnglePrec〜180°の間なら、
line[j]の角度は180°を越えて0°〜AnglePrecの間も比較対象になるということです。
line[]が角度でソートされてたらjを配列の最初の数字である1か-32768に戻すだけですが、
レイヤ>クラス>属性>角度の優先順位でソートしているのでjの値が単純には決まりません。

重複チェック手続きを呼び出すたびにline[i]の座標変換するのは処理速度の面では無駄です。
しかし処理速度に最適化すると、読みにくいスクリプトになる可能性があります。

masafumiさん、
>if nLine <= 2 then begin
>errMsg:= '線を2本以上選択してください!';
の部分は、図形を選択せずに実行するとエラーになるのに気付いて最期のほうで追加しました。
あんまり深く考えてなかったかも、です。


RE37:重なった直線の検出と処理   masafumi
Sat May 7 16:33:23 2011

またまた・・・「送信」ボタンを押さないとミスに気がつかない・・・。
まるでマーフィーの法則みたいですね。(^^;)

>約 1000 個の直線

約 10000個です。


RE36:重なった直線の検出と処理   masafumi
Sat May 7 16:27:54 2011

与太郎さん、お疲れ様です。ソース見せていただきました。
なんか、スッキリとまとまっていますね。実行時間もずいぶん早いです。
約 1000 個の直線で 4890 個の重複部分を削除するのに約7秒でした。(^_^)

>function XY2Vec(x, y:real):vector;

私のように、わざわざ var を使って
Procedure (var Vec1:vector; ax,ay:real);
にしなくても、function で返り値を vector で返せば良いのですねぇ。勉強になります。

簡単にしか見ていませんが、直線が2本の時に拾ってきません。たぶん

>if nLine <= 2 then begin
>errMsg:= '線を2本以上選択してください!';

この部分だと思います。 if nLine < 2 then begin ですとうまくいきます。
それと下記のデータ(私の想定重複部分です)で試してみてください。
私の環境では重複部分の長い方の直線を削除している場合が有ります。

Procedure Line_Plot;
Begin
MoveTo(-6500 , 4400);
LineTo(-5214.15206231032 , 4925.84196812896);
MoveTo(-6500 , 4400);
LineTo(-240 , 6960);
MoveTo(-240 , 6960);
LineTo(-3370 , 5680);
MoveTo(-2527.26083634201 , 994.781588302832);
LineTo(-3655.13962967792 , 154.294987499708);
MoveTo(-400 , 2580);
LineTo(-1418.98058184208 , 1820.66350872337);
MoveTo(-400 , 2580);
LineTo(-4560 , -520);
MoveTo(-2527.26083634201 , 994.781588302832);
LineTo(-1418.98058184208 , 1820.66350872337);
MoveTo(610.835961879696 , 199.180755906419);
LineTo(1982.4066407619 , 1380.37065891642);
MoveTo(-1178.32807624061 , -1341.63848818716);
LineTo(2400 , 1740);
MoveTo(-760 , 1380);
LineTo(-760 , 5062.29444609817);
MoveTo(-760 , 3992.57278145965);
LineTo(-760 , 6148.22401474636);
MoveTo(-760 , 2311.73076923077);
LineTo(-760 , 798.415106071581);
MoveTo(-4560 , -520);
LineTo(-5620 , 2760);
MoveTo(-5620 , 2760);
LineTo(-5090 , 1120);
MoveTo(-3200 , 2160);
LineTo(-1178.32807624061 , -1341.63848818716);
MoveTo(-2527.26083634201 , 994.781588302832);
LineTo(-3200 , 2160);
MoveTo(-2527.26083634201 , 994.781588302832);
LineTo(-1178.32807624061 , -1341.63848818716);
MoveTo(-5050 , 5950);
LineTo(-400 , 2580);
MoveTo(-5050 , 5950);
LineTo(-2725 , 4265);
End;
Run(Line_Plot);



RE34:重なった直線の検出と処理   masafumi
Wed May 4 22:21:32 2011

>通常のEqualPtは厳密過ぎますので、隠しコマンドのEqPt2Dを使えば誤差を設定出来ます。
>EqPt2Dはver.11からですが、同等のものでEqPtがあります。こいつはver.10.5から使用
>出来ます。

相変わらずマニアックな関数を使っていますねぇ。(笑)

リファレンスに載っていない関数は動作が保証されてなく、動作確認は自己責任でってことになり
検証には、けっこう時間がかかります。臆病な私は近づかないようにしています。(^^;)


RE33:重なった直線の検出と処理    石男
Mon May 2 20:25:28 2011

masafumiさん、お疲れさまでした。

>の値が「0」にならずに...
やはり、誤差を最初から認めないのはいけませんよね。PtOnLineとOverlapLineLineで
そうしているんですからね。

>2直線が重複していなくても同一角度で始点・終点どちらかの端点が同じ座標
>(2直線が接している)
ならば、こんなのはどうでしょうか?

 IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN
 IF NOT( EqPt2D( v4, v5, Precision ) ) THEN BEGIN

通常のEqualPtは厳密過ぎますので、隠しコマンドのEqPt2Dを使えば誤差を設定出来ます。
EqPt2Dはver.11からですが、同等のものでEqPtがあります。こいつはver.10.5から使用
出来ます。


RE32:重なった直線の検出と処理   masafumi
Mon May 2 14:03:21 2011

角度の誤差には単位は関係ないですね。というより時には誤動作を起こしそうです。

>IF ((-Precision <= gValue) and (gValue <= Precision)) THEN BEGIN

は別に定数を設けて

const
Precision2=0.00001;
        ・
        ・
        ・
IF ((-Precision2 <= gValue) and (gValue <= Precision2)) THEN BEGIN

の方が良さそうです。


RE31:重なった直線の検出と処理   masafumi
Mon May 2 13:24:20 2011

どうでもいいところで、またミスってました。(^^;)

>今まで、ずぅ〜〜〜っと Get_Fixed_Vlue の中でシコシコと値を取得しては書いて Get_Fixed_Vlue 関数を作って

  Set_Fixed_Vlue 関数を作って

ですね。(ハァー)


RE30:重なった直線の検出と処理   masafumi
Mon May 2 13:16:49 2011


石男さん、お疲れ様です。ずいぶん良くなりましたね。
それでもまだ、検索に引っかからない場合が有りました。

>gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );

の値が「0」にならずに、浮動小数点で

gValue := 1.16415321826935e-010
gValue := 3.32016497850418e-007

のような値になるため、

>IF gValue = 0 THEN BEGIN{ 0= 平行}

の条件をクリア出来ないことが多分に有ります。この値は角度を比較するためだけの値ですから

gValue :=Round(gValue*100000);

のように適当に丸めるか、与太郎さんの言われるように

>角度の差が一定値以下なら処理するというやり方に変えたほうが良いでしょう。

Precision := 0.0001;
IF ((-Precision <= gValue) and (gValue <= Precision)) THEN BEGIN

のようにした方が良いようですね。それと

IF NOT( ( onLine = FALSE ) & ( onLine2 = FALSE ) ) THEN BEGIN

この部分ですが、v,v1 の直線が v2,v3 の直線より短くて v2,v3 の直線の内側に有る場合( v,v1 の
始点・終点がどちらも v2,v3 の始点・終点の内側。シツコイ?)はどちらも FALSE を返して、重複
していないと解釈しているようです。(今回の設定には必要なさそうですが)それでも

PROCEDURE Get_Find

を下記のように変更してみました。 onLine を noLine1 に変更して noLine3 noLine4 を追加し
グローバル変数だったのをこのルーチンへ移動しました。
Precision を 0.001→0.0001 に変更。gValue の誤差と PtOnLine の誤差の両方に兼用ってのは
まずいかな・・・とも思いましたがそのままいきます。(^^;)


{////////////////////////////// Get_Find ////////////////////////////}
PROCEDURE Get_Find;
VAR
Precision : REAL;
onLine1, onLine2 : BOOLEAN;
onLine3, onLine4 : BOOLEAN; {この部分追加}
BEGIN
Precision := 0.0001/gUnit;{許容誤差}
msg1:=' 同一線上の 図形数検索中 ';
i := 0;
j := 0;
chkCO := 0;
REPEAT
i := i+1;
j := i;
REPEAT
j := j+1;

{同一角度かをチェック}
IF ( lineArray[ i ].Lang = lineArray[ j ].Lang ) THEN BEGIN
V_GetSegPt( lineArray[ i ].Lh, v, v1 );
V_GetSegPt( lineArray[ j ].Lh, v2, v3 );
gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );
IF ((-Precision <= gValue) and (gValue <= Precision)) THEN BEGIN
onLine1 := PtOnLine( v2, v, v1, Precision );
onLine2 := PtOnLine( v3, v, v1, Precision );}

{------------- 下2行追加 -------------}
onLine3 := PtOnLine( v, v2, v3, Precision );
onLine4 := PtOnLine( v1, v2, v3, Precision );
{----------------------- 追加部分も条件判断する ---------------------------------------}
IF NOT((onLine1=FALSE) & (onLine2=FALSE) & (onLine3=FALSE) & (onLine4=FALSE)) THEN BEGIN
IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN{重複線分の処理}
IF lineArray[ i ].flg = FALSE THEN BEGIN
lineArray[ i ].flg := TRUE;
chkCO := chkCO+1;
SetSelect( lineArray[ i ].Lh );
IF ( lineArray[ i ].layName = 'レイヤ-1' )&( lineArray[ i ].clName = '一般' ) THEN BEGIN
SetPenFore( lineArray[ i ].Lh, 65535, 0, 65535 );{pink}
END;
END;
IF lineArray[ j ].flg = FALSE THEN BEGIN
lineArray[ j ].flg := TRUE;
chkCO := chkCO+1;
SetSelect( lineArray[ j ].Lh );
IF ( lineArray[ j ].layName = 'レイヤ-1' )&( lineArray[ j ].clName = '一般' ) THEN BEGIN
SetPenFore( lineArray[ j ].Lh, 65535, 0, 65535 );{pink}
END;
END;

V_DrawLocPt( v4 );
V_DrawLocPt( v5 );
END;
END;
END;
IF ( i mod 50 ) = 0 THEN Message( msg1, chkCO, ' / 検索済み図形数 ', ( i ) );
END;
UNTIL ( j = gLine ) OR ( lineArray[ i ].Lang < lineArray[ j ].Lang );
UNTIL ( i= ( gLine-1 ) );

END;
{-------------------------------------- ここまで ----------------------------------------}

これで私の想定していた重複部分はクリアされました。(^_^)

あと、2直線が重複していなくても同一角度で始点・終点どちらかの端点が同じ座標(2直線が接している)
の時も True とFalse を返してきます。この場合

IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN

の v4 と v5 は同じ座標になります。直線を画く分には影響はないでしょうが chkCO := chkCO+1; はカウント
され選択状態になります。(頭がオーバーヒート寸前なので、必要ならばこの部分はどなたかお願いします(笑))


もう一つ目から鱗・・・。

PushAttrs と PopAttrs

今まで、ずぅ〜〜〜っと Get_Fixed_Vlue の中でシコシコと値を取得しては書いて Get_Fixed_Vlue 関数を作って
その中で元に戻していました。(ナサケナイ・・・)



RE29:重なった直線の検出と処理    石男
Sun May 1 17:29:49 2011

やはり気になりましたのでいじってみました...
構造体の動的配列を使っていますが、オバーフローの処理はしていません。

以前のままですと重複線分の数があってないようなのでフラグを立ててチェックしました。
レイヤ名とクラス名をついでに取るようにしました。

PROCEDURE DelEqual_Lines;
CONST
Err = 9999;
kRound1 = 10000;
kRound2 = 180*kRound1;
TYPE
myLines = STRUCTURE
Lh : HANDLE;
Lang : REAL;
clName, layName : STRING;
flg : BOOLEAN;
END;

VAR
gUnit : INTEGER; {単位}
v, v1, v2, v3, v4, v5 : VECTOR;
gValue : REAL;
onLine, onLine2 : BOOLEAN;
lineArray: DYNARRAY[ ] OF myLines;
gLine : LONGINT;
chkCO : INTEGER;
i, j : LONGINT;
msg1, msg2 : STRING;

{設定単位を取得}
{////////////////////////////// Get_Fixed_Vlue ////////////////////////////}
PROCEDURE Get_Fixed_Vlue;
VAR
upi : REAL;
fraction, display : LONGINT;
format : INTEGER;
name, squareName : STRING;
BEGIN
gUnit:=Err;
{単位及び単位(平方)を取得}
GetUnits( fraction, display, format, upi, name, squareName );
IF squareName = ' sq mm' THEN gUnit:=1 {ミリメートル}
ELSE IF squareName = ' sq cm' THEN gUnit:=100 {センチメートル}
ELSE IF squareName = ' sq m' then gUnit:=1000; {メートル}
End;

{線分の始点と終点をベクトルで}
{////////////////////////////// V_GetSegPt ////////////////////////////}
PROCEDURE V_GetSegPt( seg_h : HANDLE; VAR st_v, ed_v : VECTOR );
BEGIN
GetSegPt1( seg_h, st_v.x, st_v.y );
GetSegPt2( seg_h, ed_v.x, ed_v.y );
END;

{2D基準点をベクトルで}
{////////////////////////////// V_DrawLocPt ////////////////////////////}
PROCEDURE V_DrawLocPt( vec : VECTOR );
BEGIN
Locus( vec.x, vec.y );
END;

{線分のハンドルを取得}
{////////////////////////////// GetLineHandle ////////////////////////////}
FUNCTION GetLineHandle( hd :HANDLE): BOOLEAN;
BEGIN
IF GetType( hd ) = 2 THEN BEGIN{GetTypeN--2011}
i := i+1;
lineArray[ i ].Lh := hd;
lineArray[ i ].Lang := Round( HAngle( lineArray[ i ].Lh )*kRound1 ); {直線の角度}
IF lineArray[ i ].Lang < 0 THEN lineArray[ i ].Lang := Round( lineArray[ i ].Lang+kRound2 );
IF lineArray[ i ].Lang = kRound2 THEN lineArray[ i ].Lang := 0;
lineArray[ i ].clName := GetClass( lineArray[ i ].lh );{クラス取得}
lineArray[ i ].layName := GetLName( GetLayer( lineArray[ i ].lh ) );{レイヤ取得}
lineArray[ i ].flg := FALSE;{チェックカウンターのためのフラグの初期化}
END;
END;

{外積を求める--REAL値}
{///////////////////////////// V_CrossProduct2D ////////////////////////////}
FUNCTION V_CrossProduct2D( vec1, vec2 : VECTOR ): REAL;
BEGIN
V_CrossProduct2D := ( vec1.x*vec2.y ) - ( vec1.y*vec2.x );
END;

{直線の角度をソート}
{////////////////////////////// Q_Sort_Angle ////////////////////////////}
PROCEDURE Q_Sort_Angle( left, right : LONGINT );
VAR
pivot : REAL;
tmpAng : REAL;
tmpH : HANDLE;
msg : STRING;
temp2 : myLines;
BEGIN
msg :='直線を角度でソート中! ';
Message( msg, ' / ', right );
IF left < right THEN
BEGIN
pivot := ( lineArray[ left ].Lang+lineArray[right].Lang )/2;
i := left;
j := right;
REPEAT
while ( lineArray[ i ].Lang < pivot ) DO i:= i+1;
while ( lineArray[ j ].Lang > pivot) DO j:= j-1;
IF ( i <= j ) THEN BEGIN
tmpAng := lineArray[ i ].Lang; tmpH := lineArray[ i ].Lh;
temp2 := lineArray[ i ];
lineArray[ i ].Lang := lineArray[ j ].Lang; lineArray[ i ].Lh := lineArray[ j ].Lh;
lineArray[ j ].Lang := tmpAng; lineArray[ j ].Lh := tmpH;
lineArray[ j ] := temp2;
i := i+1;
j := j-1;
END;
UNTIL ( i > j );
Q_Sort_Angle( left, j );
Q_Sort_Angle( i, right );
END;
END;

{////////////////////////////// Get_Find ////////////////////////////}
PROCEDURE Get_Find;
VAR
Precision : REAL;
BEGIN
Precision := 0.001/gUnit;{許容誤差}
msg1:=' 同一線上の 図形数検索中 ';
i := 0;
j := 0;
chkCO := 0;
REPEAT
i := i+1;
j := i;
REPEAT
j := j+1;

{同一角度かをチェック}
IF ( lineArray[ i ].Lang = lineArray[ j ].Lang ) THEN BEGIN
V_GetSegPt( lineArray[ i ].Lh, v, v1 );
V_GetSegPt( lineArray[ j ].Lh, v2, v3 );
gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );
IF gValue = 0 THEN BEGIN
onLine := PtOnLine( v2, v, v1, Precision );
onLine2 := PtOnLine( v3, v, v1, Precision );

IF NOT( ( onLine = FALSE ) & ( onLine2 = FALSE ) ) THEN BEGIN
IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN{重複線分の処理}
IF lineArray[ i ].flg = FALSE THEN BEGIN
lineArray[ i ].flg := TRUE;
chkCO := chkCO+1;
SetSelect( lineArray[ i ].Lh );
IF ( lineArray[ i ].layName = 'レイヤ-1' )&( lineArray[ i ].clName = '一般' ) THEN BEGIN
SetPenFore( lineArray[ i ].Lh, 65535, 0, 65535 );{pink}
END;
END;
IF lineArray[ j ].flg = FALSE THEN BEGIN
lineArray[ j ].flg := TRUE;
chkCO := chkCO+1;
SetSelect( lineArray[ j ].Lh );
IF ( lineArray[ j ].layName = 'レイヤ-1' )&( lineArray[ j ].clName = '一般' ) THEN BEGIN
SetPenFore( lineArray[ j ].Lh, 65535, 0, 65535 );{pink}
END;
END;

V_DrawLocPt( v4 );
V_DrawLocPt( v5 );
END;
END;
END;
IF ( i mod 50 ) = 0 THEN Message( msg1, chkCO, ' / 検索済み図形数 ', ( i ) );
END;
UNTIL ( j = gLine ) OR ( lineArray[ i ].Lang < lineArray[ j ].Lang );
UNTIL ( i= ( gLine-1 ) );

END;
{////////////////////////////// Main ////////////////////////////}
BEGIN
PushAttrs;
DSelectAll;
Get_Fixed_Vlue;
IF gUnit=Err THEN
BEGIN
msg1:='単位を変更してください。';
AlrtDialog(msg1);
END ELSE
BEGIN
gLine := Count( T = LINE );
Message( Concat( '線分の数 = ', gLine ) );
ALLOCATE lineArray[ 1..gLine ];
ForEachObjectInLayer( GetLineHandle, 0, 0, 1);
Q_Sort_Angle( 1, gLine );

Get_Find; {比較する}
msg1 := Concat( '重複線分の数 = ', chkCO,' 線分の数 = ',gLine );
Message( msg1 );
AlrtDialog( msg1 );
END;
PopAttrs;
END;
RUN( DelEqual_Lines );


RE27:重なった直線の検出と処理   masafumi
Fri Apr 29 22:15:32 2011

今、いろいろ見直していましたら、またまたミスを発見。

function GetAngle(ax,ay,bx,by:Real):Longint;

このルーチンは必要ないですね。(涙)
石男さんのガイセキを取り入れたことによって、まったく必要にないモノになっていす。
お騒がせいたしました。これ上は見ないことにしましょう!。(フゥ〜!)

連休は温泉にでも行ってきます。


RE26:重なった直線の検出と処理   masafumi
Fri Apr 29 10:13:31 2011

石男さんのレスを見て初めて気がつきました。目から鱗です。

ForEach...

最初の引数は図形のハンドルを返すものとばかり思い込んでいました。
「関数型サブルーチンの名前」なんですねぇ。
(リファレンスをどのように読んだらそうなるのか? 自分)

ありがとうございます。


RE25:重なった直線の検出と処理    石男
Thu Apr 28 23:49:41 2011

過去最長のレスかな?

試してはいませんが、図形のハンドルを頼りにGetClassとGetLayer&GetLNameを使えば
図形のどのクラスとレイヤに所属しているかが分かると思いますが...

{////////////////////////////// GetLine2Handle ////////////////////////////}
FUNCTION GetLine2Handle( objH :HANDLE): BOOLEAN;
BEGIN
IF GetType( objH ) = 2 THEN BEGIN
lineCO := lineCO+1;
lineHandle[lineCO] := objH;
ClName[lineCO]:=GetClass(objH);
LName[lineCO]:=GetLName( GetLayer(objH) );
END;
END;
こんな感じにすれば、多分大丈夫なのでは...

>でもGWはお外で遊びましょ!
はい、観光地はどこも閑古鳥が鳴いています、みんな遊びに行きましょう(笑)


RE23:重なった直線の検出と処理   masafumi
Thu Apr 28 21:50:40 2011

>このネタ、完全にオモチャになっていますね(笑)

いえいえ、お勉強です。(笑)

>>procedure Get_Find;の中のchkCO:=chkCO+1;ですが、一度前の方で初期化しないと
>変な数になってしまいます。ついでにSetSelectも付けました。

あっ、完全に忘れていました。m(_ _)m

SetSelect もいいですが、2つの Locus の代わりに MoveTo・LineTo としてレイヤ情報
によって色分けすれば、当初の目的に近づけそうですね。


>ForEachObjectInLayer( GetLine2Handle, 0, 0, 1);

使ったことがないので何とも言えないのですが、今回の条件の中にレイヤ・クラスと
図形の関係を知る必要が有ったような・・・。
レイヤ名(ハンドルでもいいのですが)と図形との関係は取得出来るのでしょうか?
図形のハンドルだけを取得するには良さそうですね。


RE22:重なった直線の検出と処理    石男
Thu Apr 28 18:20:22 2011

このネタ、完全にオモチャになっていますね(笑)

>procedure Get_Find;の中のchkCO:=chkCO+1;ですが、一度前の方で初期化しないと
変な数になってしまいます。ついでにSetSelectも付けました。

{************************************* 比較 *************************************}
procedure Get_Find;
var
i,j:Integer;
LAngle:Real;
x1,y1,x2,y2:Real;
v,v1,v2:Vector;
v3,v4,v5:Vector;
IntValue : INTEGER;
gValue, gValue2 : REAL;
onLine, onLine2 : BOOLEAN;
Precision:Real;
begin
msg1:=' 重複図形の数を検索中 ';
Precision:=0.001/gUnit;{許容誤差}
i:=0;
j:=0;
chkCO:=0;
repeat
i:=i+1;
j:=i;
repeat
j:=j+1;
V_Convert(v,v1,SX[i],SY[i],EX[i],EY[i]);
{同一角度かをチェック}
if (lineAngle[i]=lineAngle[j]) then
begin
V_Convert(v2,v3,SX[j],SY[j],EX[j],EY[j]);
gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );

IF gValue = 0 THEN BEGIN{ 0= 平行}
onLine := PtOnLine( v2, v, v1, Precision );
onLine2 := PtOnLine( v3, v, v1, Precision );
IF NOT( ( onLine = FALSE ) & ( onLine2 = FALSE ) ) THEN BEGIN
IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN
SetSelect(lineHandle[i]);
SetSelect(lineHandle[j]);
Locus( v4.x, v4.y );
Locus( v5.x, v5.y );
chkCO:=chkCO+1;
END;
END;
END;
end;

if (i mod 50)=0 then Message(msg1,chkCO,' / 検索済み図形数 ',(i));

until (j=lineCO) or (lineAngle[i] < lineAngle[j]);
until (i=(lineCO-1));
Clrmessage;
end;

>PtOnLine 関数と OverlapLineLine 関数...
あるものは使う主義なので探し出してでも使います(笑)

それと完全に蛇足なのですが、複数のレイヤにまたがる直線のハンドルの取り方がわから
なくなり、レファレンスを眺めて思いついたやり方なのですが...

サブルーチン
{線分のハンドルを取得}
{////////////////////////////// GetLine2Handle ////////////////////////////}
FUNCTION GetLine2Handle( objH :HANDLE): BOOLEAN;
BEGIN
IF GetType( objH ) = 2 THEN BEGIN
lineCO := lineCO+1;
lineHandle[lineCO] := objH;
END;
END;

として、メインの中で
lineCO := 0;
ForEachObjectInLayer( GetLine2Handle, 0, 0, 1);
というやり方はどうでしょう、何かあなた任せのような感じですが(笑)


RE21:重なった直線の検出と処理   masafumi
Thu Apr 28 15:53:44 2011

なんか・・・いっぱい書き込んでますねぇ(自分)
与太郎さんにご指摘いただいた部分を少し変更して、石男さんの関数を組み込んでみました。
実行速度は問題ないようです。5000 点の直線の検索で 30 秒かかりません。

Precision:=0.001 の基準単位がわかりませんので、とりあえず「ミリメートル」を基準にしました。
Locus が微妙にずれるのが気になりますが、Locus のルーチンを通過するときは v, v1, v2, v3
の座標を使うようにすれば問題ないですね。

それにしても・・・
PtOnLine 関数と OverlapLineLine 関数・・・あやしい関数を使っていますねぇ。(笑)



{**************************** 直線の重複を知る ******************************}
procedure DelEqual_Test;
const
Err=9999;
kRound1=10000;
kRound2=180*kRound1;
var
gUnit :Integer; {単位}
lineCo :LongInt; {直線の数}
lineAngle :ARRAY [0..30000] OF LongInt; {直線の角度}
lineHandle :ARRAY [0..30000] OF Handle; {直線のハンドル}
SX,SY :ARRAY [0..30000] OF Real; {直線の始点座標}
EX,EY :ARRAY [0..30000] OF Real; {直線の終点座標}
chkCO :Integer;
msg1,msg2:String;
k:integer;

{********************************* 設定単位を取得 *********************************}
PROCEDURE Get_Fixed_Vlue;
VAR
upi:Real;
fraction,display:LONGINT;
format :INTEGER;
name,squareName :STRING;
Begin
gUnit:=Err;
{単位及び単位(平方)を取得}
GetUnits( fraction,display,format,upi,name,squareName);
if squareName = ' sq mm' then gUnit:=1 {ミリメートル}
else if squareName = ' sq cm' then gUnit:=100 {センチメートル}
else if squareName = ' sq m' then gUnit:=1000; {メートル}
End;

{****************************** 2点の角度を計算 **********************************}
function GetAngle(ax,ay,bx,by:Real):Longint;
var
pV1,pV2:Vector;
begin
pV1.x:=ax;
pV1.y:=ay;
pV2.x:=bx;
pV2.y:=by;
{比較するための角度なので小数点2位までを整数にする}
GetAngle:=Round(Vec2Ang(pV2-pV1)*kRound1);
end;

{***************************** 直線の角度をソート *********************************}
procedure Q_Sort_Angle(left,right:Longint);
var
i, j :Longint;
pivot :Real;
tmpAng :Real;
tmpH :Handle;
msg :String;
begin
msg:='直線を角度でソート中! ';
Message(msg,' / ',right);
if left < right then
begin
pivot:= (lineAngle[left]+lineAngle[right])/2;
i:= left;
j:= right;
repeat
while (lineAngle[i] < pivot) do i:= i+1;
while (lineAngle[j] > pivot) do j:= j-1;
if (i <= j) then
begin
tmpAng:=lineAngle[i]; tmpH:=lineHandle[i];
lineAngle[i]:=lineAngle[j]; lineHandle[i]:=lineHandle[j];
lineAngle[j]:=tmpAng; lineHandle[j]:=tmpH;
i:= i+1;
j:= j-1;
end;
until (i > j);
Q_Sort_Angle(left, j);
Q_Sort_Angle(i, right);
end;
end;

{**************************** 座標をベクトルに変換 *****************************}
procedure V_Convert(Var vec1,vec2:Vector; ax,ay,bx,by:Real);
begin
vec1.x:=ax; vec1.y:=ay;
vec2.x:=bx; vec2.y:=by;
end;

{外積を求める--REAL値}
{///////////////////////////// V_CrossProduct2D ////////////////////////////}
FUNCTION V_CrossProduct2D( vec1, vec2 : VECTOR ): REAL;
BEGIN
V_CrossProduct2D := ( vec1.x*vec2.y ) - ( vec1.y*vec2.x );
END;


{************************************* 比較 *************************************}
procedure Get_Find;
var
i,j:Integer;
LAngle:Real;
x1,y1,x2,y2:Real;
v,v1,v2:Vector;
v3,v4,v5:Vector;
IntValue : INTEGER;
gValue, gValue2 : REAL;
onLine, onLine2 : BOOLEAN;
Precision:Real;
begin
msg1:=' 重複図形の数を検索中 ';
Precision:=0.001/gUnit;{許容誤差}
i:=0;
j:=0;
repeat
i:=i+1;
j:=i;
repeat
j:=j+1;
V_Convert(v,v1,SX[i],SY[i],EX[i],EY[i]);
{同一角度かをチェック}
if (lineAngle[i]=lineAngle[j]) then
begin
V_Convert(v2,v3,SX[j],SY[j],EX[j],EY[j]);
gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );

IF gValue = 0 THEN BEGIN{ 0= 平行}
onLine := PtOnLine( v2, v, v1, Precision );
onLine2 := PtOnLine( v3, v, v1, Precision );
IF NOT( ( onLine = FALSE ) & ( onLine2 = FALSE ) ) THEN BEGIN
IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN
Locus( v4.x, v4.y );
Locus( v5.x, v5.y );
chkCO:=chkCO+1;
END;
END;
END;
end;

if (i mod 50)=0 then Message(msg1,chkCO,' / 検索済み図形数 ',(i));

until (j=lineCO) or (lineAngle[i] < lineAngle[j]);
until (i=(lineCO-1));
Clrmessage;
end;


{************* 角度を取得してソート。始点座標・終点座標取得 ******************}
procedure GetLine_Zahyou_Angle;
var
i:integer;
begin
for i:=1 to lineCO do
begin
lineAngle[i]:=Round(HAngle(lineHandle[i])*kRound1); {直線の角度}
if lineAngle[i] < 0 then lineAngle[i]:=Round(lineAngle[i]+ kRound2);
if lineAngle[i]= kRound2 then lineAngle[i]:=0;
end;

Q_Sort_Angle(1,lineCO); {直線の角度でソート}
Clrmessage;

for i:=1 to lineCO do
begin
GetSegPt1(lineHandle[i], SX[i], SY[i]); {直線の始点の座標}
GetSegPt2(lineHandle[i], EX[i], EY[i]); {直線の終点の座標}
end;
end;

{************************ すべての直線のハンドルを取得 **********************}
procedure GetLineHandle;
var
layerH :Handle; {レイヤのハンドル}
objH :Handle; {図形のハンドル}
Typ :Integer;
begin
lineCO:=0;
layerH:=FLayer; {最上位のレイヤのハンドル}
repeat
objH:=FInLayer(layerH); {レイヤ上の最上位の図形のハンドル}
repeat
Typ:=GetType(objH);
{図形タイプが直線の時の処理}
if Typ=2 then
begin
lineCO:=lineCO+1;
lineHandle[lineCO]:=objH; {各直線のハンドル}
end;
objH:=NextObj(objH);
Until (objH=NIL);
layerH:=NextLayer(layerH);
until (LayerH=NIL);
end;

{******************************** スタート ***********************************}
begin
Get_Fixed_Vlue;
if gUnit=Err then
begin
msg1:='単位を変更してください。';
AlrtDialog(msg1);
end else begin
GetLineHandle; {先にすべての直線のハンドルを取得}
GetLine_Zahyou_Angle; {角度・角度ソート・座標を取得}
{
msg1:='D:\VS重複図形削除\作業用\chkList.txt';
Rewrite(msg1);
for k:=1 to lineCO do
begin
msg2:=Concat('lineHandle[',k,']= ',lineHandle[k],' lineAngle[',k,']= ',lineAngle[k]);
Writeln(msg2);
end;
Close(msg1);
}
Get_Find; {比較する}
msg1:=concat('重複図形の数 = ',chkCO,' 全直線数 = ',lineCO);
AlrtDialog(msg1);
end;
end;
run(DelEqual_Test);


RE20:重なった直線の検出と処理   masafumi
Thu Apr 28 10:56:18 2011

与太郎さん

>まず、GetAngle関数の戻り値はlongint型なので角度は1000倍にして返さないといけないのですが、
>GetAngle:=Round(Vec2Ang(pV2-pV1)*1000)/1000; で最後に1/1000にしているので、
>結果が整数値の角度(0°,1°, 2°…)になっています。
>これは最初に定数 RoundFactor = 1000; で定義しておいて、
>GetAngle:=Round(Vec2Ang(pV2-pV1)*RoundFactor); と直した方がいいでしょう。

はっはっはぁ〜!(笑)

さすが与太郎さんですね。付け焼き刃がすっかりバレしまいました。
元々は検索を少しでも早くしようと Longint 型で使っているのですが、サンプルを書くときに real の
方が分かりやすいかと思い変更したのです。

GetAngle:=Round(Vec2Ang(pV2-pV1)*10000);

ってな感じですね。チェックしたようでもミスがでてしまいますねぇ。

>角度の差が一定値以下なら処理するというやり方に変えたほうが良いでしょう。

これも参考になります。ありがとうございます。


RE19:重なった直線の検出と処理   masafumi
Thu Apr 28 10:28:29 2011

石男さん

角度をソートした後、

procedure Get_Find;

の repeat のなかで石男さんの方法を取り入れれば、もっと簡単に重複部分が検索できると思っています。
今回は自分で使っている方法が検証が簡単だったのでこの方法にしただけです。


「RE19:重なった直線の検出と処理」の訂正    与太郎
Thu Apr 28 10:27:11 2011

if LAngle < 0 then LAngle:= LAngle + 1800*RoundFactor;は、
if LAngle < 0 then LAngle:= LAngle + 180*RoundFactor;が正しいです。


RE19:重なった直線の検出と処理    与太郎
Thu Apr 28 10:21:28 2011

masafumiさん、おひさしぶりです。
重複チェックのスクリプトがサラッと書ける時代になったんですねえ。
わたしも書いてみようという気になりましたよ。

ところで角度の扱いがおかしいところがありました。
まず、GetAngle関数の戻り値はlongint型なので角度は1000倍にして返さないといけないのですが、
GetAngle:=Round(Vec2Ang(pV2-pV1)*1000)/1000; で最後に1/1000にしているので、
結果が整数値の角度(0°,1°, 2°…)になっています。
これは最初に定数 RoundFactor = 1000; で定義しておいて、
GetAngle:=Round(Vec2Ang(pV2-pV1)*RoundFactor); と直した方がいいでしょう。

それに関連して、
if LAngle < 0 then LAngle:= LAngle + 180;
if LAngle = 180 then LAngle:= 0;
も、
if LAngle < 0 then LAngle:= LAngle + 1800*RoundFactor;
if 180*RoundFactor <= LAngle then LAngle:= LAngle - 180*RoundFactor;
と変わります。

でも実は角度を丸めてしまうのはまずいと思います。
値を丸めると、浮動小数点数の最小桁程度しか違わなくても別々の値になることがあるからです。
たとえれば、となり家との間に県境があるようなもので、税金を納める先も違ってきます。
だから角度のデータはそのままにして、
角度の差が一定値以下なら処理するというやり方に変えたほうが良いでしょう。
ただ、最小値と最大値付近で余計な手間がかかってしまいますが。
これは座標値の場合も同じです。


RE16:重なった直線の検出と処理   masafumi
Wed Apr 27 13:35:54 2011

かなりいい加減な感覚で答えていましたので確認のためチェックしてみました。
約5000点の直線を総当たりで検索しますと、5分〜6分かかります。
角度をソートしますと、30秒以下でした。m(_ _)m

この差をどう感じるかは個人の感覚ですね。

ソートは下記のようにしています。角度をすべてプラスの値に変更してからソートしています。
同一直線上の図形を調べるところまでしかやっていません。


{**************************** 直線の重複を知る ******************************}
procedure DelEqual_Test;
var
lineCo :LongInt; {直線の数}
lineAngle :ARRAY [0..30000] OF Real; {直線の角度}
lineHandle :ARRAY [0..30000] OF Handle; {直線のハンドル}
SX,SY :ARRAY [0..30000] OF Real; {直線の始点座標}
EX,EY :ARRAY [0..30000] OF Real; {直線の終点座標}
chkFlg :ARRAY [0..30000] OF Boolean; {同一直線上のフラグ}
chkCO :Integer;
msg1,msg2:String;
k:integer;


{****************************** 2点の角度を計算 **********************************}
function GetAngle(ax,ay,bx,by:Real):Longint;
var
pV1,pV2:Vector;
begin
pV1.x:=ax;
pV1.y:=ay;
pV2.x:=bx;
pV2.y:=by;
{比較するための角度なので小数点2位までを整数にする}
GetAngle:=Round(Vec2Ang(pV2-pV1)*1000)/1000;
end;

{***************************** 直線の角度をソート *********************************}
procedure Q_Sort_Angle(left,right:Longint);
var
i, j :Longint;
pivot :Real;
tmpAng :Real;
tmpH :Handle;
msg :String;
begin
msg:='直線を角度でソート中! ';
Message(msg,' / ',right);
if left < right then
begin
pivot:= (lineAngle[left]+lineAngle[right])/2;
i:= left;
j:= right;
repeat
while (lineAngle[i] < pivot) do i:= i+1;
while (lineAngle[j] > pivot) do j:= j-1;
if (i <= j) then
begin
tmpAng:=lineAngle[i]; tmpH:=lineHandle[i];
lineAngle[i]:=lineAngle[j]; lineHandle[i]:=lineHandle[j];
lineAngle[j]:=tmpAng; lineHandle[j]:=tmpH;
i:= i+1;
j:= j-1;
end;
until (i > j);
Q_Sort_Angle(left, j);
Q_Sort_Angle(i, right);
end;
end;

{************************************* 比較 *************************************}
procedure Get_Find;
var
i,j:integer;
LAngle:Real;
x1,y1,x2,y2:Real;

begin
msg1:=' 同一線上の 図形数検索中 ';

i:=0;
j:=0;
chkCO:=0;
repeat
i:=i+1;
j:=i;
repeat
j:=j+1;

{同一角度かをチェック}
if (lineAngle[i]=lineAngle[j]) then
begin
{先に座標を比較}
x1:=Round(SX[i]/1000); y1:=Round(SY[i]/1000);
x2:=Round(SX[j]/1000); y2:=Round(SY[j]/1000);

{基準線と検索図形の始点座標から角度を取得}
if EqualPt(x1,y1,x2,y2) then LAngle:=lineAngle[i]
else begin
LAngle:=GetAngle(SX[i], SY[i],SX[j], SY[j]);
if LAngle < 0 then LAngle:=LAngle+180;
if LAngle=180 then LAngle:=0;
end;

{2直線が同一線上に有るとき}
if (lineAngle[i]=LAngle) then
begin

if chkFlg[i]=False then
begin
chkCO:=chkCO+1;
chkFlg[j]:=True;
{---------------------------------------------------------}

{ ここでX座標をチェックして2直線の重なり具合をチェック}

{---------------------------------------------------------}
end;
end;
end;

if (i mod 50)=0 then Message(msg1,chkCO,' / 検索済み図形数 ',(i));

until (j=lineCO) or (lineAngle[i] < lineAngle[j]);
until (i=(lineCO-1));
end;


{************* 角度を取得してソート。始点座標・終点座標取得 ******************}
procedure GetLine_Zahyou_Angle;
var
i:integer;
begin
for i:=1 to lineCO do
begin
chkFlg[i]:=False; {初期化}
lineAngle[i]:=Round(HAngle(lineHandle[i])*1000)/1000; {直線の角度}
if lineAngle[i] < 0 then lineAngle[i]:=Round(lineAngle[i]+180);
if lineAngle[i]=180 then lineAngle[i]:=0;
end;

Q_Sort_Angle(1,lineCO); {直線の角度でソート}
Clrmessage;

for i:=1 to lineCO do
begin
GetSegPt1(lineHandle[i], SX[i], SY[i]); {直線の始点の座標}
GetSegPt2(lineHandle[i], EX[i], EY[i]); {直線の終点の座標}
end;
end;

{************************ すべての直線のハンドルを取得 **********************}
procedure GetLineHandle;
var
layerH :Handle; {レイヤのハンドル}
objH :Handle; {図形のハンドル}
Typ :Integer;
begin
lineCO:=0;
layerH:=FLayer; {最上位のレイヤのハンドル}
repeat
objH:=FInLayer(layerH); {レイヤ上の最上位の図形のハンドル}
repeat
Typ:=GetType(objH);
{図形タイプが直線の時の処理}
if Typ=2 then
begin
lineCO:=lineCO+1;
lineHandle[lineCO]:=objH; {各直線のハンドル}
end;
objH:=NextObj(objH);
Until (objH=NIL);
layerH:=NextLayer(layerH);
until (LayerH=NIL);
end;

{******************************** スタート ***********************************}
begin
GetLineHandle; {先にすべての直線のハンドルを取得}
GetLine_Zahyou_Angle; {角度・角度ソート・座標を取得}
{
msg1:='D:\VS重複図形削除\作業用\chkList.txt';
Rewrite(msg1);
for k:=1 to lineCO do
begin
msg2:=Concat('lineHandle[',k,']= ',lineHandle[k],' lineAngle[',k,']= ',lineAngle[k]);
Writeln(msg2);
end;
Close(msg1);
}
Get_Find; {比較する}
msg1:=concat('同一直線上の数 = ',chkCO,' 全直線数 = ',lineCO);
AlrtDialog(msg1);
end;
run(DelEqual_Test);

{--------------------------------- ここまで -------------------------------------}


RE15:重なった直線の検出と処理   masafumi
Tue Apr 26 10:49:53 2011

>線分数が数千本くらいだと、そのルーチンを組み込んだ方がよいのか、なくてもがまん
>できるくらいなのか、直感的な印象を教えていただければありがたいです

数千本ではソートの必要はないと思います。


RE13:重なった直線の検出と処理   masafumi
Mon Apr 25 10:52:04 2011

私は先にすべての直線の角度を取得してソートしています。ソートすることで2直線が平行かを
検索するときに、検索する角度より大きい(又は小さい)角度になったら検索をストップするこ
とができます。(以前、与太郎さんに教えていただいた方法です。)
多角形の各辺との比較にも使用したためです。

その後は石男さんと同様に、平行な直線の時は、基準直線の始点座標と平行な直線の始点座標から
角度を出して、角度が同一、又は座標が同一の時は2直線は同一線上にあると判断しています。

直線の重なり具合は2直線の始点・終点のX座標を比較して判断しています。角度が90度の時は
X座標はすべて同一になりますから、そのときはY座標で判断します。
(う〜ん、なんか・・・アナログ的な発想のような感じですねぇ)


RE12:重なった直線の検出と処理    石男
Sun Apr 24 9:28:29 2011

後だしですが、ひとつ書き込みます。

線分同士を比較して平行なら、重なる可能性があるので、線分の始点、終点のそれぞれを
もう一つの線分上にあるかを判定して重複の判定とします。

外部関数を使用していますが、ver.10.5以上なら問題ないはずです。
平行判定に外積を使います、外積=0なら平行ですが、この辺の許容誤差はVWの内部精度任せ
になります。
PROCEDURE xxxxx;
CONST
Precision = 0.001;{許容誤差}
VAR
v, v1, v2, v3, v4, v5 : VECTOR;
IntValue : INTEGER;
gValue, gValue2 : REAL;
onLine, onLine2 : BOOLEAN;
{線分の始点と終点をベクトルで}
{////////////////////////////// V_GetSegPt ////////////////////////////}
PROCEDURE V_GetSegPt( seg_h : HANDLE; VAR st_v, ed_v : VECTOR );
BEGIN
GetSegPt1( seg_h, st_v.x, st_v.y );
GetSegPt2( seg_h, ed_v.x, ed_v.y );
END;

{外積を求める--REAL値}
{///////////////////////////// V_CrossProduct2D ////////////////////////////}
FUNCTION V_CrossProduct2D( vec1, vec2 : VECTOR ): REAL;
BEGIN
V_CrossProduct2D := ( vec1.x*vec2.y ) - ( vec1.y*vec2.x );
END;

{////////////////////////////// Main ////////////////////////////}
BEGIN
V_GetSegPt( FSActLayer, v, v1 );
V_GetSegPt( NextSObj( FSActLayer ), v2, v3 );
gValue := V_CrossProduct2D( ( v1-v ), ( v3-v2 ) );
IF gValue = 0 THEN BEGIN{ 0= 平行}
onLine := PtOnLine( v2, v, v1, Precision );
onLine2 := PtOnLine( v3, v, v1, Precision );
Message( Concat( onLine, '&', onLine2 ) );
IF NOT( ( onLine = FALSE ) & ( onLine2 = FALSE ) ) THEN BEGIN
IF OverlapLineLine( v, v1, v2, v3, v4, v5, Precision) THEN BEGIN
Locus( v4.x, v4.y );
Locus( v5.x, v5.y );
END;
END ELSE BEGIN
Message( '重複なし' );
END;
END ELSE BEGIN
Message( '平行ではない' );
END;
END ;

RUN( xxxxx ) ;

すっきりしたやり方を考えたつもりなんですが、その割ではないかもしれません。


RE7:重なった直線の検出と処理    与太郎
Mon Apr 18 18:09:07 2011

昨日のレスは判りにくく、タイプミスや勘違いもあったので、スクリプトを書いてみました。
UnionRectは重なった領域ではなく、2つの四角形を包括する領域を返す手続きだったので、
今回は使えませんでした。
IsOverlapped関数の最初の4個のパラメータ(pt11, pt12, pt21, pt22)は、本当は「var」を付け
るべきではないのですが、VectorScriptの仕様で「var」を付けたほうが簡単なのでそうしました。
GetOverlapp手続きも同様です。

procedure test;{ 直線の部分重複テスト }
{$ DEBUG}
const
__Precision = 0.001;{許容誤差}
__LineObj = 2;
var
__h1, h2__:handle;
__v11, v12, v21, v22, v31, v32__:vector;
__
__function IsOverlapped(var pt11, pt12, pt21, pt22:vector; prec:real; var pt31, pt32:vector):boolean;
__{ 2本の直線が重なっていたらTrueを返す。pt31とpt32には重なった部分の座標が入る。 }
__var
____result__:boolean;
____rot__:real;
____
____procedure SwapR(var d1, d2:real);
____var
______tmp__:real;
____begin
______tmp:= d1;
______d1:= d2;
______d2:= tmp;
____end;{SwapR}
____
____procedure GetOverlapp(var x11, x12, x21, x22:real; var x31, x32:real);
____begin
______if x12 < x11 then SwapR(x11, x12);
______if x22 < x21 then SwapR(x21, x22);
______if x11 < x21 then x31:= x21 else x31:= x11;
______if x12 < x22 then x32:= x12 else x32:= x22;
____end;{GetOverlapp}
____
__begin
____result:= false;
____rot:= Vec2Ang(pt12 - pt11);
____pt12:= pt11 + Ang2Vec(0, Norm(pt12 - pt11));
____pt21:= pt11 + Ang2Vec(Vec2Ang(pt21 - pt11) - rot, Norm(pt21 - pt11));
____pt22:= pt11 + Ang2Vec(Vec2Ang(pt22 - pt11) - rot, Norm(pt22 - pt11));
____if ((pt21.x < pt11.x) & (pt22.x < pt11.x)) | ((pt12.x < pt21.x) & (pt12.x < pt22.x)) then begin
______result:= false;
____end
____else begin
______GetOverlapp(pt11.x, pt12.x, pt21.x, pt22.x, pt31.x, pt32.x);
______pt31.y:= pt21.y + (pt21.x - pt11.x) / (pt22.x - pt21.x) * (pt22.y - pt21.y);
______pt32.y:= pt21.y + (pt22.x - pt11.x) / (pt22.x - pt21.x) * (pt22.y - pt21.y);
______result:= (Abs(pt31.y - pt11.y) < prec) & (Abs(pt32.y - pt12.y) < prec);
______if result then begin
________pt31:= pt11 + Ang2Vec(Vec2Ang(pt31 - pt11) + rot, Norm(pt31 - pt11));
________pt32:= pt11 + Ang2Vec(Vec2Ang(pt32 - pt11) + rot, Norm(pt32 - pt11));
______end;
____end;
____IsOverlapped:= result;
__end;{IsOverlapped}
__
begin{test}
__h1:= FSActLayer;
__if (h1 = nil) | (GetType(h1) <> LineObj) then begin
____AlrtDialog('アクティブレイヤの直線を2本選択してください。');
__end
__else begin
____h2:= NextSObj(h1);
____if (h2 = nil) | (GetType(h2) <> LineObj) then begin
______AlrtDialog('アクティブレイヤの直線を2本選択してください。');
____end
____else begin
______GetSegPt1(h1, v11.x, v11.y); GetSegPt2(h1, v12.x, v12.y);
______GetSegPt1(h2, v21.x, v21.y); GetSegPt2(h2, v22.x, v22.y);
______if IsOverlapped(v11, v12, v21, v22, Precision, v31, v32) then begin
________MoveTo(v31.x, v31.y);
________LineTo(v32.x, v32.y);
________SetLW(LNewObj, 42);
________SetPenBack(LNewObj, 32767, 0, 0);
________SetPenFore(LNewObj, 32767, 0, 0);
________SetDSelect(h1);
________SetDSelect(h2);
________ReDrawAll;
______end
______else begin
________AlrtDialog('直線を2本の線は重なっていません。');
______end;
____end;
__end;
end;
Run(test);


RE6:重なった直線の検出と処理    与太郎
Sun Apr 17 15:36:54 2011

>与太郎さん、地図の場所は、たぶんご近所ですよ。
あらま、そうなんですか。

EqualPtだと座標値が微妙に違うとTrueになりません。
だからNereEqualPtみたいな関数を作ったりします。
許容誤差は関数パラメータかグローバル変数にします。

2本の線が部分的に重なっているかどうかの判定は、
どちらかの線が水平になるように2本の線を回転して、
Y座標の差を調べればいいと思います。
例えば次のような関数を考えます。
function IsOverlapped(pt11, pt12, pt21, pt22,:vector; prec:rea; var pt31, pt32:vector):boolean; 
pt11とpt12が線1、pt21とpt22が線2、pt31とpt32は重なる部分の線の座標です。
pt11を基点にすると回転角度は rot:=Vec2Ang(pt12-pt11); になるので、
pt12:= pt11 + Ang2Vec(0, Norm(pt12 - pt11);
pt21:= pt11 + Ang2Vec(Vec2Ang(pt21-pt11) - rot, Norm(pt21-pt11));
pt22:= pt11 + Ang2Vec(Vec2Ang(pt22-pt11) - rot, Norm(pt22-pt11);
で、線(pt11 - pt12)が水平になるように座標変換します。
pt21.xとpt22.xの両方がpt11.x以下か、
pt21.xとpt22.xの両方がpt12.x以上なら2本の線は重ならないので、
関数の戻り値としてFalseを返して終了します。
それ以外なら重なっている範囲を計算します。
つまり、pt11.x〜pt12.x と pt21.x〜pt22.x が重なる範囲です。
これは、手続きUnionRectでY座標に適当な値を入れて求められます。
求めた2つのX座標はpt31.xとpt32.xに入れます。
線(pt21-pt22)の、X=pt31.xとX=pt32.xでのY座標を計算して、
pt11.yとの差がどちらも許容誤差以下なら、
2本の線は重なっているので関数の戻り値としてTtueを返します。
一方でも許容誤差を超えていれば、関数の戻り値としてFalseを返します。
重なっている部分の線の座標は、pt31.y:=0; pt32.y:=0; として、
最初とは逆方向に座標を回転して求めます。
pt31:= pt11 + Ang2Vec(Vec2Ang(pt31-pt11) + rot, Norm(pt31-pt11));
pt32:= pt11 + Ang2Vec(Vec2Ang(pt32-pt11) + rot, Norm(pt32-pt11));

と、文章で書いてみましたが、これじゃあまるで暗号だ。
素直にスクリプトを書いたほうが判りやすかったですかね。


RE4:重なった直線の検出と処理   masafumi
Sat Apr 16 14:15:06 2011

角度はVectorWorksの内部計算でも計算誤差・丸め誤差等で微妙に違うときが出ていましたので、厳密な判断をせずに
適当な位置で丸めて比較した方が良いように思います。(Ver10.5の時です。Ver2011ではまだ検証していません)

>実はこれ、時代の異なる地籍図の比較のひとつとして、間口変化だけを強調した
>表現を行いたいということが始まり。

んっ、昔の京都の間口税くらいしか思いつきません・・・?


RE3:重なった直線の検出と処理    与太郎
Sat Apr 16 13:28:38 2011

なかなか興味深い作業ですね。
新旧データを別レイヤにしておいて、
新しいレイヤに新、旧、共通部分をクラス
別に生成すればいいんでしょうか?


Re:ワークシートにレイヤーの高さ(Z)と(△Z)を取り出し    与太郎
Thu Mar 24 8:39:45 2011

下のほうの「全レイヤの情報をWSに書き出す」と「レイヤ情報を一度に設定する」が、
レイヤの高度と厚みの設定についての書き込みです。


ワークシートにレイヤーの高さ(Z)と(△Z)を取り出し    江戸の黒板当番
Thu Mar 24 0:11:35 2011

3Dパス図形(J)では色々お世話になりました。
石男さんの意地の最終作でなんとかなりました。
ありがとうございます。

と言った舌の根も乾かぬ間に
ワークシートにレイヤーの高さ(Z)と(△Z)を取り出したり
ワークシートの数値でレイヤーの高さを指定する方法って
ございますのでしょうか?



Re6:関数廃止予定のため使用できません??    石男
Mon Mar 7 10:24:11 2011

すみませんでした、下の書き込みに間違いがありました。
下のダイアログでは設定情報がきちんと反映されません、簡単にやり過ぎました...
こちらでお願いします。
{ 設定情報の取得 }
FUNCTION GetSettings: BOOLEAN;
VAR
dialog, choiceNum, oldChoiceNum : INTEGER;
turnQuantityStr, pitch, str, str2, str3, str4 : STRING;
PROCEDURE dialog_Handler( VAR item : LONGINT; data : LONGINT );
BEGIN

CASE item OF
SetupDialogC: BEGIN
AddChoice( dialog, 5, 'パスに垂直', 0 );
AddChoice( dialog, 5, 'グランド(2D)プレーンに垂直', 1 );

AddChoice( dialog, 9, '回転角で指定', 0 );
AddChoice( dialog, 9, 'ピッチで指定', 1 );
AddChoice( dialog, 9, 'ねじれなし', 2 );

AddChoice( dialog, 17, 'Off', 0 );
AddChoice( dialog, 17, 'On', 1 );

END;
9: BEGIN
IF ( oldChoiceNum = 0 ) THEN
SetItemText( dialog, 11, turnQuantityStr )
ELSE IF ( oldChoiceNum = 1 ) THEN
SetItemText( dialog, 11, pitch );
GetSelectedChoiceIndex( dialog, 9, 0, choiceNum );

IF( ( choiceNum = 0 ) & ( oldChoiceNum <> 1 ) ) THEN
BEGIN
SetItemText( dialog, 10, '回転角:' );
SetItemText( dialog, 11, turnQuantityStr );
oldChoiceNum:=1;
END
ELSE IF( ( choiceNum = 1 ) & ( oldChoiceNum <> 2 ) ) THEN
BEGIN
SetItemText( dialog, 10, 'ピッチ:' );
SetItemText( dialog, 11, pitch );
oldChoiceNum:=2;
END
ELSE IF( ( choiceNum = 2 ) & ( oldChoiceNum <> 3 ) ) THEN
BEGIN
SetItemText( dialog, 10, 'ねじれ:' );
SetItemText( dialog, 11, 'なし' );
oldChoiceNum := 3;
END;
END;
{OK}
1: BEGIN
GetSelectedChoiceIndex( dialog, 5, 0, g_sectionDirType );{断面の方向}
GetSelectedChoiceIndex( dialog, 17, 0, choiceNum );{三角パッチ}
IF ( choiceNum = 0 ) THEN
g_triangular := FALSE
ELSE
g_triangular := TRUE;
GetSelectedChoiceIndex( dialog, 9, 0, choiceNum );{ねじれの指定方法}
IF ( choiceNum = 0 ) THEN BEGIN
g_isQuantity := TRUE;
GetItemText( dialog, 7, str );{11}
GetItemText( dialog, 11, str2 );{13}
GetItemText( dialog, 13, str3 );{14}
GetItemText( dialog, 15, str4 );{15}
GetSettings := ( ValidAngStr( str, g_startAngle ) & ValidAngStr( str2, g_turnQuantity ) &
ValidAngStr( str3, g_scaleStart ) & ValidAngStr( str4, g_scaleEnd ) );
END ELSE
IF ( choiceNum = 1 ) THEN BEGIN
g_isQuantity := FALSE;
GetItemText( dialog, 7, str );{11}
GetItemText( dialog, 11, str2 );{13}
GetItemText( dialog, 13, str3 );{14}
GetItemText( dialog, 15, str4 );{15}
GetSettings := ( ValidAngStr( str, g_startAngle ) & ValidNumStr( str2, g_turnQuantity ) &
ValidAngStr( str3, g_scaleStart ) & ValidAngStr( str4, g_scaleEnd ) );
END ELSE
IF ( choiceNum = 2 ) THEN BEGIN
g_isQuantity := TRUE;
g_turnQuantity := 0;
GetItemText( dialog, 7, str );{11}
GetItemText( dialog, 13, str3 );{14}
GetItemText( dialog, 15, str4 );{15}
GetSettings := ( ValidAngStr( str, g_startAngle )&
ValidAngStr( str3, g_scaleStart )& ValidAngStr( str4, g_scaleEnd ) );
END;
END;

END;{Case}
END;
{///////////////////////// GetSettings Main ////////////////////////////}
BEGIN
pitch := '1000';
turnQuantityStr := '0';
oldChoiceNum := 1;
GetSettings := FALSE;
dialog := CreateLayout( '3Dパス図形(J)_2011', TRUE, 'OK', 'Cancel' );

{create controls}
CreateStaticText( dialog, 4, '断面の方向:', 20 );
CreatePulldownMenu( dialog, 5, 16);

CreateStaticText( dialog, 6, '断面の回転:', 20 );
CreateEditText( dialog, 7, '0° 0'' 0" ', 20 );

CreateStaticText( dialog, 8, 'ねじれの指定方法:', 20 );
CreatePulldownMenu( dialog, 9, 16);

CreateStaticText( dialog, 10, '回転角:', 20 );
CreateEditText( dialog, 11, turnQuantityStr, 20 );

CreateStaticText( dialog, 12, '始点拡大率:', 20 );
CreateEditText( dialog, 13, '1', 16 );

CreateStaticText( dialog, 14, '終点拡大率:', 20 );
CreateEditText( dialog, 15, '1', 16 );

CreateStaticText( dialog, 16, '三角パッチ:', 20 );
CreatePulldownMenu( dialog, 17, 16);


SetFirstLayoutItem( dialog, 4 );
SetBelowItem( dialog, 4, 5, 0, 0 );
SetRightItem( dialog, 4, 6, 0, 0 );
SetBelowItem( dialog, 6, 7, 0, 0 );
SetBelowItem( dialog, 5, 8, 0, 0 );
SetBelowItem( dialog, 8, 9, 0, 0 );
SetRightItem( dialog, 8, 10, 0, 0 );
SetBelowItem( dialog, 10, 11, 0, 0 );
SetBelowItem( dialog, 9, 12, 0, 0 );
SetBelowItem( dialog, 12, 13, 0, 0 );
SetRightItem( dialog, 12, 14, 0, 0 );
SetBelowItem( dialog, 14, 15, 0, 0 );
SetBelowItem( dialog, 13, 16, 0, 0 );
SetBelowItem( dialog, 16, 17, 0, 0 );

{run test dialog}
IF RunLayoutDialog( dialog, dialog_Handler ) = 1 Then BEGIN
GetSettings := TRUE;
END;
END;

これで2011以降も使えるかと思います...


Re5:関数廃止予定のため使用できません??    石男
Wed Mar 2 12:47:29 2011

3Dパス図形(J)ですが、本体は「3Dパス図形(J)...vsm」と同じ階層の「src」フォルダの中
にある「3_3DPath.px」です。
エラーの原因の一つが「GetType」です、これを「GetTypeN」に変更(8個あります)
使い方は一緒なので単なる変更だけで良いはずです。
問題なのはダイアログ部分です。ダイアログは「GetSettings」サブルーチンです。
こいつを...
{ 設定情報の取得 }
FUNCTION GetSettings: BOOLEAN;
VAR
dialog : INTEGER;
selectindex : INTEGER;
str, str2, str3, str4 : STRING;
turnQuantityStr, pitch : STRING;
PROCEDURE dialog_Handler( VAR item : LONGINT; data : LONGINT );
BEGIN

CASE item OF
SetupDialogC: BEGIN
{2010よりPullDownMenuの設定が変更}
AddChoice( dialog, 5, 'パスに垂直', 0 );
AddChoice( dialog, 5, 'グランド(2D)プレーンに垂直', 1 );

AddChoice( dialog, 9, '回転角で指定', 0 );
AddChoice( dialog, 9, 'ピッチで指定', 1 );
AddChoice( dialog, 9, 'ねじれなし', 2 );

AddChoice( dialog, 17, 'Off', 0 );
AddChoice( dialog, 17, 'On', 1 );

END;
9: BEGIN
GetSelectedChoiceIndex( dialog, 9, 0, selectindex );
IF selectindex <> -1 THEN BEGIN
CASE selectindex OF
0: BEGIN
SetItemText( dialog, 10, '回転角:' );
SetItemText( dialog, 11, turnQuantityStr );
END;
1: BEGIN
SetItemText( dialog, 10, 'ピッチ:' );
SetItemText( dialog, 11, pitch );
END;
2: BEGIN
SetItemText( dialog, 10, 'ねじれ:' );
SetItemText( dialog, 11, 'なし' );
END;
END;
END;
END;
{OK}
1: BEGIN
GetSelectedChoiceIndex( dialog, 5, 0, g_sectionDirType );{断面の方向}
GetSelectedChoiceIndex( dialog, 17, 0, selectindex );{三角パッチ}
IF ( selectindex = 1 ) THEN
g_triangular := FALSE
ELSE
g_triangular := TRUE;
GetSelectedChoiceIndex( dialog, 9, 0, selectindex );{ねじれの指定方法}
IF ( selectindex = 1 ) THEN BEGIN
g_isQuantity := TRUE;
GetItemText( dialog, 7, str );{GetFieldより変更}
GetItemText( dialog, 11, str2 );
GetItemText( dialog, 13, str3 );
GetItemText( dialog, 15, str4 );
GetSettings := ( ValidAngStr( str, g_startAngle ) & ValidAngStr( str2, g_turnQuantity ) &
ValidAngStr( str3, g_scaleStart ) & ValidAngStr( str4, g_scaleEnd ) );
END ELSE
IF ( selectindex = 2 ) THEN BEGIN
g_isQuantity := FALSE;
GetItemText( dialog, 7, str );
GetItemText( dialog, 11, str2 );
GetItemText( dialog, 13, str3 );
GetItemText( dialog, 15, str4 );
GetSettings := ( ValidAngStr( str, g_startAngle ) & ValidNumStr( str2, g_turnQuantity ) &
ValidAngStr( str3, g_scaleStart ) & ValidAngStr( str4, g_scaleEnd ) );
END ELSE
IF ( selectindex = 3 ) THEN BEGIN
g_isQuantity := TRUE;
g_turnQuantity := 0;
GetItemText( dialog, 7, str );
GetItemText( dialog, 13, str3 );
GetItemText( dialog, 15, str4 );
GetSettings := ( ValidAngStr( str, g_startAngle )&
ValidAngStr( str3, g_scaleStart )& ValidAngStr( str4, g_scaleEnd ) );
END;
END;

END;{Case}
END;
{///////////////////////// GetSettings Main ////////////////////////////}
BEGIN
pitch := '1000';
turnQuantityStr := '0';
GetSettings := FALSE;
dialog := CreateLayout( '3Dパス図形(J)_2011', TRUE, 'OK', 'Cancel' );

{create controls}
CreateStaticText( dialog, 4, '断面の方向:', 20 );
CreatePulldownMenu( dialog, 5, 16);

CreateStaticText( dialog, 6, '断面の回転:', 20 );
CreateEditText( dialog, 7, '0° 0'' 0" ', 20 );

CreateStaticText( dialog, 8, 'ねじれの指定方法:', 20 );
CreatePulldownMenu( dialog, 9, 16);

CreateStaticText( dialog, 10, '回転角:', 20 );
CreateEditText( dialog, 11, turnQuantityStr, 20 );

CreateStaticText( dialog, 12, '始点拡大率:', 20 );
CreateEditText( dialog, 13, '1', 16 );

CreateStaticText( dialog, 14, '終点拡大率:', 20 );
CreateEditText( dialog, 15, '1', 16 );

CreateStaticText( dialog, 16, '三角パッチ:', 20 );
CreatePulldownMenu( dialog, 17, 16);


SetFirstLayoutItem( dialog, 4 );
SetBelowItem( dialog, 4, 5, 0, 0 );
SetRightItem( dialog, 4, 6, 0, 0 );
SetBelowItem( dialog, 6, 7, 0, 0 );
SetBelowItem( dialog, 5, 8, 0, 0 );
SetBelowItem( dialog, 8, 9, 0, 0 );
SetRightItem( dialog, 8, 10, 0, 0 );
SetBelowItem( dialog, 10, 11, 0, 0 );
SetBelowItem( dialog, 9, 12, 0, 0 );
SetBelowItem( dialog, 12, 13, 0, 0 );
SetRightItem( dialog, 12, 14, 0, 0 );
SetBelowItem( dialog, 14, 15, 0, 0 );
SetBelowItem( dialog, 13, 16, 0, 0 );
SetBelowItem( dialog, 16, 17, 0, 0 );

{run test dialog}
IF RunLayoutDialog( dialog, dialog_Handler ) = 1 Then BEGIN
GetSettings := TRUE;
END;
END;
に書き換えます。{ 設定情報の取得 }と{ パスオブジェクトの取得 }の間ですよ。
取りあえず、これで動くはずなんですが...


Re4:関数廃止予定のため使用できません??    江戸の黒板当番
Tue Mar 1 16:44:44 2011

皆さん、Vectorscriptの困り事待っているかのような反応の良さ
ありがとうございます。


BeginDialog
AddButton
kDialogWidth
kDialogHeight
AddField
AddChoiceItem
turnQuantityStr
GetDialog
SetTitle
InsertChoice
DialogEvent
GetField
GetSelChoice
choiceNum
choiceStr
SetField
GetSelChoice
g_sectionDirType
ValidAngStr
g_startAngle
g_turnQuantity
ValidAngStr
g_scaleEnd
GetSettings
以上がひっかかっているようです。
まあ、少々時間がかかるとこととまだ2011では廃止まではされていないと
いうことですね。
そろそろ対策をしなくてということですな。


Re3:関数廃止予定のため使用できません??    石男
Tue Mar 1 14:03:55 2011

与太郎さんのご指摘の通りダイアログ関係のエラーが主な原因です。
それとGetTypeをGetTypeNに変更...。

いずれにしてもダイアログのテストが必要なので少々時間がかかりますが...


Re2:関数廃止予定のため使用できません??    与太郎
Tue Mar 1 13:46:36 2011

警告がわずらわしかったら、環境設定の「その他」でOFFに出来ます。
良いことかどうかは判りませんが。


Re:関数廃止予定のため使用できません??    与太郎
Tue Mar 1 13:33:37 2011

エラーはダイアログ生成に関するものですね。
クラシカルなカスタムダイアログは、VW9からずっと「将来廃止される予定」でしたが、
とうとう本当に廃止されました。
カスタムダイアログは全てモダンダイアログに書き直す必要があります。
BeginDialog → CreateLayout
AddButton → CreatePushButton
AddField → CreateStaticText、CreateEditText
のように、同じ機能のサブルーチンに書き換えます。

モダンダイアログはアイテムを自動的にレイアウトしてくれるのですが、
きめ細かい調整が難しくダイアログが大きくなりがちなので、
私は数回しか使ったことがありませんが、
これからはモダンダイアログでやるしかないですね。


関数廃止予定のため使用できません??    江戸の黒板当番
Tue Mar 1 11:24:40 2011

与太郎さま、石男さまお助け下さいまし。
VW2011の販売に伴い、今まで一応、販売していたA+A作図・編集キットが
OpenTipsダウンロードの中に加えられソース公開になりました。


困ったことが昔から便利に使わせて貰っていた3Dパス図形(J)がその中に入ってしまったんですよ。

無理矢理ダウンロードしたオープンソースをえいやとVW2011の放り込み
使ってみると{ Warning: この関数は廃止予定のため使用できません。 } が
いっぱい出てきます。
3Dパス図形(J) は斜線の立体表示にはかかせないツールなんざます。
これを新しい関数に置き換える作業って難しいんでしょうね。
今はエラーメッセージにもめげずに使っているんですけど

ライセンス貸せばできるとか過激な解決方法でも良いです。
なんか良いアイデアありませんか?


メモ帳から貼り付けたら...    与太郎
Tue Feb 22 13:51:11 2011

下の書き込みですが、メモ帳のウィンドウの幅が狭かったため、コピペしたら余計な改行
が入ってしまい、本当にばがやろさまでした。
ついでに2/14の「レイヤ名を一度に変更する(1)」のタイトルが本文の頭にも付いてる
のは、iPhoneのメモ+からそのまま貼り付けたからです。メモ+では本文の最初の行がメ
モのタイトルになります。iPhoneで長文を先頭行を除いて選択するのは面倒なので、勢い
全選択となります。で、掲示板の書き込み欄に貼ってしまうと、スクロールして先頭に移
動するのもまた面倒です。
でも確認を怠ったことは、ばがやろさまと言うしかありません。


クラス名を一度に変更する    与太郎
Tue Feb 22 13:23:03 2011

前回の書込みについては悩んでも仕方ないので、構わずスクリプトを書きました。
クラスとレイヤでは名前の取得方法や名前の重複を確認する方法が違いますが、
基本的には「レイヤ名を一度に変更する(2/2)」の「レイヤ」の部分を「クラス」に変えたものです。
ただ、定数名や変数名の「L」、「Lyr」、「Layer」を「C」、「Cls」、「Class」に直すのが結構面倒だっ

たので、
思い切って全部取り除きました。
これで、シンボル名や図形の名前を変更するスクリプトに改造するときなども楽になるはずです。
また、「PushAttrs;」、「TextFont();」、「TextSize();」が抜けていたので追加しました。
名前の配列変数は動的配列は使わず250個に固定していますが、上限チェックはしていません。

procedure ChangeClassNameByWS;
{ ワークシートで設定したクラス名を元に、クラス名を変えます。 }
{$ DEBUG}
const
__WSName = 'ClassNameWS';
__ClmName = 1;__NameText = 'ClassName';
__ClmNewName = 2;__NewNameText = 'New ClassName';
__MaxClmNum = 2;
__MaxArray = 250;
__DefFontName = 'MS ゴシック';
__DefTextSize = 9;
__SQ = Chr(39);{ ' }
__TempName = 'TempName_';
__WSheet = 18;
__ClassDef = 94;

var
__hWS__:handle;
__name__:string;
__i, j, num, nWSRow, row, clm, nMsg, iTmp__:integer;
__nm, newNm, tmpNm__:array[1..MaxArray] of string;
__ErrMsg__:string;
__
__procedure Alart(msg:string);
__{ 警告ダイアログを出す、またはエラーメッセージを記憶する。 }
__begin
____nMsg:= nMsg + 1;
____WriteLn(msg);
____if errMsg = '' then begin
______errMsg:= msg;
______AlrtDialog(msg);
____end
____else
______errMsg:= Concat(errMsg, Chr(13), msg);
__end;{Alart}
__
__function AddSQ(s:string):string;
__{ 名前の中の「'」を「'」+「'」 に直す。 }
__var
____result__:string;
____i, j, lng__:integer;
__begin
____result:= s;
____lng:= Len(result);
____i:= 1;
____while (i <= lng) do begin
______if Copy(result, i, 1) = SQ then begin
________Insert(SQ, result, i);
________lng:= lng + 1;
________i:= i + 1;
______end;{if}
______i:= i + 1;
____end;{while}
____AddSQ:= result;
__end;{AddSQ}
__
__function IsClassName(nm:string):boolean;
__{ 名前がクラス名ならTrueを返す。 }
__var
____h__:handle;
__begin
____h:= GetObject(nm);
____IsClassName:= (h <> nil) & (GetType(h) = ClassDef);
__end;{IsClassName}

__procedure WriteCell(h:handle; rw, clm:integer; dt:string);
__{ セルに文字列を書き込む。 }
__begin
____SetWSCellFormula(h, rw, clm, rw, clm, dt);
__end;{WriteCell}
__
__function CellAsStr(h:handle; rw, clm:integer):string;
__{ セルの文字を返す。 }
__var
____result__:string;
__begin
____GetWSCellString(h, rw, clm, result);
____CellAsStr:= result;
__end;{CellAsStr}
__
__function GetWS(wkSheet:string):handle;
__{ ワークシートのハンドルを返す。 }
__var
____h, hDmy__:handle;
____row, clm, i__:integer;
____wsNm, name__:string;
__begin
____h:= GetTopVisibleWS;
____if h = nil then begin
______h:= GetObject(WSName);
______if h = nil then begin
________num:= 0;
________for i:= 1 to NameNum do begin
__________name:= nameList(i);
__________h:= GetObject(name);
__________if (h <> nil) & (GetType(h) = ClassDef) then begin
____________num:= num + 1;
____________nm[num]:= name;
__________end;
________end;{for}
________SortArray(nm, num, 1);
________hDmy:= CreateWS(WSName, num+1, MaxClmNum);
________PushAttrs;
________TextFont(GetFontID(DefFontName));
________TextSize(DefTextSize);
________WriteCell(hDmy, 1, ClmName, NameText);
________WriteCell(hDmy, 1, ClmNewName, NewNameText);
________for row:= 2 to num+1 do begin
__________name:= Concat('=', SQ, AddSQ(nm[row-1]), SQ);
__________WriteCell(hDmy, row, ClmName, name);
__________WriteCell(hDmy, row, ClmNewName, name);
________end;{for}
________PopAttrs;
________ShowWS(hDmy, true);
________Alart(Concat('ワークシート「', WSName, '」を作成しました。', Chr(13),
__________'「New ClassName」の列を新しい名前に変えてから実行してください。'));
______end
______else if GetType(h) = WSheet then begin
________Alart('ワークシートが開かれていません。');
______end
______else begin
________Alart(Concat('「', WSName, '」という名前がワークシート以外で使われています。'));
______end;
____end
____else begin
______wsNm:= GetName(h);
______if WSName <> wsNm then
________Alart(Concat('設定用WSの名前は「', WSName, '」にして下さい。'))
______else begin
________GetWSRowColumnCount(h, row, clm);
________if clm < MaxClmNum then
__________Alart('WSは2列(LayerName, New LayerName)必要です。')
________else begin
__________if CellAsStr(h, 1, ClmName) <> NameText then
____________Alart(Concat('A1セルが「', NameText, '」ではありません。'))
__________else if CellAsStr(h, 1, ClmNewName) <> NewNameText then
____________Alart(Concat('B1セルが「', NewNameText, '」ではありません。'));
________end;
______end;
____end;
____if errMsg <> '' then
______h:= nil;
____GetWS:= h;
__end;{GetWS}
__
__function GetIndex(nm1:string; var nm2:array[1..MaxArray] of string): integer;
__{ 名前が一致する配列の番号を返す。 }
__var
____i__:integer;
__begin
____i:= 1;
____while (0 < i) & (i <= num) do begin
______if nm2[i] = nm1 then
________i:= -i
______else
________i:= i + 1;
____end;
____if 0 < i then
______i:= -0;
____GetIndex:= -i;
__end;{GetIndex}
__
__function IsTmpID(i:integer):boolean;
__{ 番号が仮クラス名に適合すればTrueを返す。 }
__var
____s__:string;
__begin
____s:= Concat(TempName, i);
____IsTmpID:= (GetIndex(s, nm) = 0) & (not IsClassName(s));
__end;{IsTmID}
__
begin{main}
__nMsg:= 0; errMsg:= '';
__hWS:= GetWS(WSName);
__if hWS <> nil then begin
____GetWSRowColumnCount(hWS, nWSRow, clm);
____num:= 0;
____{ WSから名前を読み込む }
____for row:= 2 to nWSRow do begin
______name:= CellAsStr(hWS, row, ClmName);
______if IsClassName(name) then begin
________num:= num + 1;
________nm[num]:= name;
________newNm[num]:= CellAsStr(hWS, row, ClmNewName);
________if newNm[num] = '' then
__________newNm[num]:= nm[num];
______end
______else
________Alart(Concat('「', name, '」というクラスはありません。'));
____end;{for}
____for i:= 1 to num do begin
______Message('レイヤ名の重複チェック中...', i, '/', num);
______for j:= i+1 to num do begin
________if nm[i] = nm[j] then
__________Alart(Concat('「', nm[i], '」というクラス名が重複しています。'));
________if newNm[i] = newNm[j] then
__________Alart(Concat('「', newNm[i], '」という新しいクラス名が重複しています。'));
______end;{for}
____end;{for}
____if errMsg = '' then begin
______Message('仮クラス名を決定中...', i, '/', num);
______iTmp:= 0;
______for j:= 1 to num do begin
________if nm[j] = newNm[j] then
__________tmpNm[j]:= nm[j]
________else begin
__________i:= GetIndex(newNm[j], nm);
__________if i = 0 then
____________tmpNm[j]:= newNm[j]
__________else begin
____________iTmp:= iTmp + 1;
____________while not IsTmpID(iTmp) do
______________iTmp:= iTmp + 1;
____________tmpNm[j]:= Concat(TempName, iTmp);
__________end;
________end;
______end;{for}
______Message('クラス名を仮クラス名に変換中...', i, '/', num);
______for i:= 1 to num do begin
________if nm[i] <> tmpNm[i] then begin
__________RenameClass(nM[i], tmpNm[i]);
________end;
______end;
______Message('仮クラス名を新しいクラス名に変換中...', i, '/', num);
______for i:= 1 to num do begin
________if tmpNm[i] <> newNm[i] then begin
__________RenameClass(tmpNm[i], newNm[i]);
________end;
______end;
______ReDraw;
____end;
____ClrMessage;
__end;
__if 1 < nMsg then
____AlrtDialog(errMsg);
end;{main}
Run(ChangeClassNameByWS);

レイヤもクラスも30個を超えてメニューに全部表示しきれなくなると、選択するのが辛くなってきます。
Win版のフォントメニューみたいに、一覧表示してくれれば助かるんですけどね。
まあ、Mac版ではメニューでスクロールホイールが使えるし、頭文字を打って移動出来るので大分助かります

が。
クラスの階層表示は正直ありがた迷惑と感じることが多いので、環境設定でオフに出来ればと思います。
あるいはFinderのリスト表示みたいに、深い階層を部分的に展開して表示するとかね。
ナビゲーションパレットなら楽だけどFundamentalsには付いてないからなぁ。
環境設定でオフと言えば、ナッジやアクティブクラス変更のショートカットキーをオフにして、矢印キーの

ショート
カットを開放出来たら、非表示レイヤをスキップしながらアクティブレイヤを切り替えたり出来て便利です


そこまでしないとしても、この2つの機能にショートカットキーは必須ではないと思うのです。
キーを打ち間違えて、知らないうちにナッジやアクティブクラスの変更をされたことってありませんか?


クラス名を変更出来ないケース    与太郎
Sat Feb 19 15:30:02 2011

レイヤ名の変更は少々面倒でも問題なく出来ましたが、
クラス名の場合は、変更しようとしても出来ないことがあります。
プラグイン・オブジェクト(PIO)の中でクラス名を付けている場合です。
クラス設定やスクリプトでそのクラスを消したり名前を変えても、
PIOのスクリプトが実行されると新しいクラスとして復活してしまいます。
PIO独自のクラス名でなく、既存のクラス名を付ける場合も同じです。
PIOがそのクラスを名前で記憶してる限り、スクリプト実行畤にはその名前
が使われるからです。
クラスを名前でなく番号で記憶することも出来ますが、
クラス番号はVWのファイル毎に異なるので、ファイル間でPIOをコピぺ
するのに不都合です。
ファイルを開き直すと番号が変わってしまう可能性もあります。
これはVWの中の人でないと確かなことは判りません。
例外は「一般」と「寸法」クラスで、それぞれ1と2に決まっています。


レイヤ名を一度に変更する(2/2)    与太郎
Fri Feb 18 15:39:38 2011

一応完成しました。
スクリプトを実行すると、レイヤ名が入ったワークシートが出来ます。
A列が現在のレイヤ名、B列が新しいレイヤ名なので、B列に御希望のレイヤ名を入れます。
もう一度実行すると、レイヤ名が全部変更されます。
そのあとまたレイヤ名を変えたいときは、「LayerNameWS」というワークシートを削除して、
最初からやって下さい。

procedure ChangeLayerNameByWS;
{ ワークシートで設定したレイヤ名を元に、レイヤ名を変えます。 }
{$ DEBUG}
const
__WSName = 'LayerNameWS';
__ClmLyrName = 1;
__ClmNewLyrName = 2;
__MaxClmNum = 2;
__MaxLayerNum = 250;
__DefFontName = 'MS ゴシック';
__DefTextSize = 9;
__SQ = Chr(39);{ ' }
__TempLayerName = 'TempLayerName-';
var
__hWS, hL, hAL__:handle;
__name__:string;
__i, j, nL, nWSL, row, clm, nMsg, iTmp__:integer;
__lyrNm, newLyrNm, tmpNm__:array[1..MaxLayerNum] of string;
__hLyr__:array[1..MaxLayerNum] of handle;
__ErrMsg__:string;
__
__procedure Alart(msg:string);
__{ 警告ダイアログを出す、またはエラーメッセージを記憶する。 }
__begin
____nMsg:= nMsg + 1;
____WriteLn(msg);
____if errMsg = '' then begin
______errMsg:= msg;
______AlrtDialog(msg);
____end
____else
______errMsg:= Concat(errMsg, Chr(13), msg);
__end;{Alart}
__
__function AddSQ(s:string):string;
__{ 名前の中の「'」を「'」+「'」 に直す。 }
__var
____result__:string;
____i, j, lng__:integer;
__begin
____result:= s;
____lng:= Len(result);
____i:= 1;
____while (i <= lng) do begin
______if Copy(result, i, 1) = SQ then begin
________Insert(SQ, result, i);
________lng:= lng + 1;
________i:= i + 1;
______end;{if}
______i:= i + 1;
____end;{while}
____AddSQ:= result;
__end;{AddSQ}
__
__procedure WriteCell(h:handle; rw, clm:integer; dt:string);
__{ セルに文字列を書き込む。 }
__begin
____SetWSCellFormula(h, rw, clm, rw, clm, dt);
__end;{WriteCell}
__
__function CellAsStr(h:handle; rw, clm:integer):string;
__{ セルの文字を返す。 }
__var
____result__:string;
__begin
____GetWSCellString(h, rw, clm, result);
____CellAsStr:= result;
__end;{CellAsStr}
__
__function GetWS(wkSheet:string):handle;
__{ ワークシートのハンドルを返す。 }
__const
____WSheet = 18;
__var
____h, hL, hDmy__:handle;
____row, clm__:integer;
____wsNm, name__:string;
__begin
____h:= GetTopVisibleWS;
____if h = nil then begin
______h:= GetObject(WSName);
______if h = nil then begin
________hDmy:= CreateWS(WSName, nL+1, MaxClmNum);
________WriteCell(hDmy, 1, ClmLyrName, 'LayerName');
________WriteCell(hDmy, 1, ClmNewLyrName, 'New LayerName');
________hL:= FLayer;
________row:= nL + 1;
________while hL <> nil do begin
__________name:= Concat('=', SQ, AddSQ(GetLName(hL)), SQ);
__________WriteCell(hDmy, row, ClmLyrName, name);
__________WriteCell(hDmy, row, ClmNewLyrName, name);
__________hL:= NextLayer(hL);
__________row:= row - 1;
________end;{while}
________PopAttrs;
________ShowWS(hDmy, true);
________Alart(Concat('ワークシート「', WSName, '」を作成しました。', Chr(13),
__________'「New LayerName」の列を新しい名前に変えてから実行してください。'));
______end
______else if GetType(h) = WSheet then begin
________Alart('ワークシートが開かれていません。');
______end
______else begin
________Alart(Concat('「', WSName, '」という名前がワークシート以外で使われています。'));
______end;
____end
____else begin
______wsNm:= GetName(h);
______if WSName <> wsNm then
________Alart(Concat('設定用WSの名前は「', WSName, '」にして下さい。'))
______else begin
________GetWSRowColumnCount(h, row, clm);
________if clm < MaxClmNum then
__________Alart('WSは2列(LayerName, New LayerName)必要です。')
________else begin
__________if CellAsStr(h, 1, ClmLyrName) <> 'LayerName'then
____________Alart('A1セルが「LayerName」ではありません。')
__________else if CellAsStr(h, 1, ClmNewLyrName) <> 'New LayerName' then
____________Alart('B1セルが「New LayerName」ではありません。');
________end;
______end;
____end;
____if errMsg <> '' then
______h:= nil;
____GetWS:= h;
__end;{GetWS}
__
__function GetIndex(nm1:string; var nm2:array[1..MaxLayerNum] of string): integer;
__{ 名前が一致する配列の番号を返す。 }
__var
____i__:integer;
__begin
____i:= 1;
____while (0 < i) & (i <= nL) do begin
______if nm2[i] = nm1 then
________i:= -i
______else
________i:= i + 1;
____end;
____if 0 < i then
______i:= -0;
____GetIndex:= -i;
__end;{GetIndex}
__
__function IsTmpLyrID(i:integer):boolean;
__{ 番号が仮レイヤ名に適合すればTrueを返す。 }
__var
____nm__:string;
__begin
____nm:= Concat(TempLayerName, i);
____IsTmpLyrID:= (GetIndex(nm, lyrNm) = 0) & (GetLayerByName(nm) = nil)
__end;{IsTmpLyrID}
__
begin{main}
__nMsg:= 0; errMsg:= '';
__nL:= NumLayers;
__hWS:= GetWS(WSName);
__if hWS <> nil then begin
____GetWSRowColumnCount(hWS, nWSL, clm);
____nL:= 0;
____{ WSから名前を読み込む }
____for row:= nWSL downto 2 do begin
______nL:= nL + 1;
______lyrNm[nL]:= CellAsStr(hWS, row, ClmLyrName);
______newLyrNm[nL]:= CellAsStr(hWS, row, ClmNewLyrName);
______if newLyrNm[nL] = '' then
________newLyrNm[nL]:= lyrNm[nL];
____end;{for}
____for i:= 1 to nL do begin
______Message('レイヤ名の重複チェック中...', i, '/', nL);
______hLyr[i]:= GetLayerByName(lyrNm[i]);
______if hLyr[i] = nil then
________Alart(Concat('「', lyrNm[i], '」というレイヤはありません。'));
______for j:= i+1 to nL do begin
________if lyrNm[i] = lyrNm[j] then
__________Alart(Concat('「', lyrNm[i], '」というレイヤ名が重複しています。'));
________if newLyrNm[i] = newLyrNm[j] then
__________Alart(Concat('「', newLyrNm[i], '」という新しいレイヤ名が重複しています。'));
______end;{for}
____end;{for}
____if errMsg = '' then begin
______Message('仮レイヤ名を決定中...', i, '/', nL);
______iTmp:= 0;
______for j:= 1 to nL do begin
________if lyrNm[j] = newLyrNm[j] then
__________tmpNm[j]:= lyrNm[j]
________else begin
__________i:= GetIndex(newLyrNm[j], lyrNm);
__________if i = 0 then
____________tmpNm[j]:= newLyrNm[j]
__________else begin
____________iTmp:= iTmp + 1;
____________while not IsTmpLyrID(iTmp) do
______________iTmp:= iTmp + 1;
____________tmpNm[j]:= Concat(TempLayerName, iTmp);
__________end;
________end;
______end;{for}
______hAL:= ActLayer;
______Message('レイヤ名を仮レイヤ名に変換中...', i, '/', nL);
______for i:= 1 to nL do begin
________if lyrNm[i] <> tmpNm[i] then begin
__________SetName(hLyr[i], tmpNm[i]);
__________Layer(GetLName(hLyr[i]));
________end;
______end;
______Message('仮レイヤ名を新しいレイヤ名に変換中...', i, '/', nL);
______for i:= 1 to nL do begin
________if tmpNm[i] <> newLyrNm[i] then begin
__________SetName(hLyr[i], newLyrNm[i]);
__________Layer(GetLName(hLyr[i]));
________end;
______end;
______Layer(GetLName(hAL));
____end;
____ClrMessage;
__end;
__if 1 < nMsg then
____AlrtDialog(errMsg);
end;{main}
Run(ChangeLayerNameByWS);


レイヤ名を一度に変更する(1)    与太郎
Mon Feb 14 9:32:29 2011

レイヤ名を一度に変更する(1)

レイヤ名を変える場合、VectorWorksは名前の重複を許さないので事前にチェックが必要です。
(1) 変更前のレイヤ名の重複チェック、
(2) 変更後のレイヤ名の重複チェック、
(3) 変更作業中に一時的に発生するレイヤ名重複の回避,
の3点です。
(1)と(2)は重複が見つかった時点でメッセージを表示して終了、で構わないでしょう。
(3)は一時的に仮のレイヤ名を付けて、あとで本当のレイヤ名に直せば良いでしょう。


レイヤ情報を一度に設定する    与太郎
Fri Feb 4 8:05:27 2011

レイヤ情報を1つずつ設定するのは面倒なので、ワークシートにレイヤの縮尺、高さ、厚みを書き込んで一度に設定
するスクリプトを書いてみました。
設定用のワークシートは、十日くらい前の書き込み「全レイヤの情報をWSに書き出す。」のprocedure LayerInfoWS;
で作成します。

procedure SetLayerInfoByWS;
{ ワークシートで設定したレイヤ情報を元にレイヤ情報を直します。 }
{$ DEBUG}
const
__WSName = 'LayerInfoWS';
__ClmLyrName = 1;
__ClmLyrScale = 2;
__ClmLyrElev = 3;
__ClmLyrTick = 4;
__MaxClmNum = 4;
__MaxLayerNum = 250;
var
__hWS, hL, hAL__:handle;
__name__:string;
__scl, elev, tick__:real;
__elevFlg, tickFlg__:boolean;
__i, nL, nWSL, row, clm, nMsg__:integer;
__lyrNm__:array[1..MaxLayerNum] of string;
__lyrErr__:array[1..MaxLayerNum] of boolean;
__ErrMsg__:string;
__
__procedure Alart(msg:string);
__{ 警告ダイアログを出す、またはエラーメッセージを記憶する。 }
__begin
____nMsg:= nMsg + 1;
____WriteLn(msg);
____if errMsg = '' then begin
______errMsg:= msg;
______AlrtDialog(msg);
____end
____else
______errMsg:= Concat(errMsg, Chr(13), msg);
__end;{Alart}
__
__function CellAsStr(h:handle; rw, clm:integer):string;
__var
____result__:string;
__{ セルの文字を返す。 }
__begin
____GetWSCellString(h, rw, clm, result);
____CellAsStr:= result;
__end;{CellAsStr}
__
__procedure ReadWS(h:handle; rw:integer; var name:string; var scl, elev, tick:real; var elevFlg, tickFlag:boolean);
__{ WSから一行分のデータを読む。 }
__var
____dt__:string;
__begin
____name:= CellAsStr(h, rw, ClmLyrName);
____dt:= CellAsStr(h, rw, ClmLyrScale);
____if (Copy(dt, 1, 4) <> '1 / ') | not ValidNumStr(Copy(dt, 5, Len(dt)-4), scl) then
______scl:= 0;
____dt:= CellAsStr(h, rw, ClmLyrElev); elevFlg:= ValidNumStr(dt, elev);
____dt:= CellAsStr(h, rw, ClmLyrTick); tickFlg:= ValidNumStr(dt, tick);
__end;{ReadWS}
__
__function GetWS(wkSheet:string):handle;
__{ ワークシートのハンドルを返す。 }
__const
____WSheet = 18;
__var
____h__:handle;
____row, clm__:integer;
____wsNm__:string;
__begin
____h:= GetTopVisibleWS;
____if h = nil then
______Alart('ワークシートが開かれていません。')
____else begin
______wsNm:= GetName(h);
______if WSName <> Copy(wsNm, 1, Len(WSName)) then
________Alart(Concat('設定用WSの名前は「', WSName, '」または「',
__________ WSName, '」で始まる名前にして下さい。'))
______else begin
________GetWSRowColumnCount(h, row, clm);
________if clm < MaxClmNum then
__________Alart('WSは4列(Layer, Scale, Elevation, Tickness)必要です。')
________else begin
__________if CellAsStr(h, 1, ClmLyrName) <> 'Layer'then
____________Alart('A1セルが「Layer」ではありません。')
__________else if CellAsStr(h, 1, ClmLyrScale) <> 'Scale' then
____________Alart('B1セルが「Scale」ではありません。')
__________else if CellAsStr(h, 1, ClmLyrElev) <> 'Elevation' then
____________Alart('C1セルが「Elevation」ではありません。')
__________else if CellAsStr(h, 1, ClmLyrTick) <> 'Tichness' then
____________Alart('D1セルが「Tichness」ではありません。');
________end;
______end;
____end;
____if errMsg <> '' then
______h:= nil;
____GetWS:= h;
__end;{GetWS}
__
__function GetIndex(nm:string): integer;
__{ 名前が一致する配列の番号を返す。 }
__var
____i__:integer;
__begin
____i:= 1;
____while (0 < i) & (i <= nWSL) do begin
______if lyrNm[i] = nm then begin
________lyrErr[i]:= false;
________i:= -i;
______end
______else
________i:= i + 1;
____end;
____if 0 < i then
______i:= -0;
____GetIndex:= -i;
__end;{GetIndex}
__
begin{main}
__nMsg:= 0; errMsg:= '';
__hWS:= GetWS(WSName);
__if hWS <> nil then begin
____GetWSRowColumnCount(hWS, row, clm);
____nWSL:= row;
____nL:= 0;
____hL:= FLayer;
____while hL <> nil do begin
______nL:= nL + 1;
______lyrNm[nL]:= GetLName(hL);
______lyrErr[nL]:= true;
______hL:= NextLayer(hL);
____end;{while}
____hAL:= ActLayer;
____for row:= 2 to nWSL do begin
______Message('Processing...', row-1, '/', nWSL-1);
______ReadWS(hWS, row, name, scl, elev, tick, elevFlg, tickFlg);
______i:= GetIndex(name);
______if i = 0 then
________Alart(Concat('「', name, '」というレイヤはありません。'))
______else begin
________hL:= GetLayerByName(name);
________if scl <> 0 then
__________SetLScale(hL, scl);
________if elevFlg & tickFlg then
__________SetLayerElevation(hL, elev, tick)
________else if elevFlg | tickFlg then
__________Alart(Concat(row, '行目:',
__________ 'elevetionとTicknessの片方だけ設定することは出来ません。'));
______end;
______ClrMessage;
____end;
____Layer(GetLName(hAL));
____for i:= 1 to nL do begin
______if lyrErr[i] then
________Alart(Concat('WSにレイヤー「', lyrNm[i], '」がありません。'));
____end;
__end;
__if 1 < nMsg then
____AlrtDialog(errMsg);
end;{main}
Run(SetLayerInfoByWS);


VectorScriptプログラミング入門   Go5
Thu Jan 27 18:51:48 2011

与太郎さん 本当にありがとうございます。
正直、言いまして
const
__Rect = 3;   て、なぁ〜に。
__PolyObj = 5;  て、なぁ〜に。
__CurveObj = 21;  て、なぁ〜に。 そんなレベルです!

石男さん 今日、ネットで調べて”VectorScriptプログラミング入門”
を 買いました。A+AのサイトのVS手習い帳も 読んでみます。

それでも なんとなくScriptに可能性を 感じているものですから
なんとか? 習得したいと 願っております。

去年、永年使っているのに 初めてVWのワークシート、
データーベースを利用してみました!
けっこう上手く使えましたし、VWの可能性も広がりました。

あせらず? 精進(^j^) します。


VectorScript入門    石男
Thu Jan 27 17:20:26 2011

>良い入門テキストが見つからず、苦戦しています
まあ、書いても売れないので出版はされないと思います
取りあえず、A+AのサイトのVS手習い帳はお勧めです
その後は、ここのバックナンバーを読むと大抵のことが書いてあると思います


↓の書き込みはわたしです    与太郎
Thu Jan 27 15:15:57 2011

....


Re3:複数の多角形の面積スタンプ   
Thu Jan 27 15:13:48 2011


アクティブレイヤの選択図形だけなら、以下のスクリプトで良いでしょう。

procedure test;
{ アクティブレイヤの選択図形を処理する。 }
{$ DEBUG}
const
__Rect = 3;
__PolyObj = 5;
__CurveObj = 21;
var
__hObj__:handle;
__nObj__:longint;
__
procedure MensekiStamp(h:handle);
begin
__{ ハンドル図形の面積をスタンプする処理。 }
__nObj:= nObj + 1;
end;{MensekiStamp}

begin{main}
__nObj:= 0;
__hObj:= FSActLayer;
__while hObj <> nil do begin
____case GetType(hObj) of
______Rect, PolyObj, CurveObj: MensekiStamp(hObj);
____end;{case}
____hObj:= NextSObj(hObj);
__end;{while}
__AlrtDialog(Concat(nObj, '個の図形に面積スタンプを押しました。'));
end;{main}
Run(test);


下のようにすれば、グループやシンボルの中でも使えます。
アクティブでないレイヤでも、選択可能な図形なら処理してくれます。
ただし、特に指定しない限りスタンプは全部アクティブレイヤに押されます。

procedure test;
{ 選択図形を処理する。 }
{$ DEBUG}
const
__SelectedObjects = 2;
__TraverseShallow = 0;
__EditableLayers = 4;
var
__nObj__:longint;
__
procedure MensekiStamp(h:handle);
begin
__{ ハンドル図形の面積をスタンプする処理。 }
__nObj:= nObj + 1;
end;{MensekiStamp}

function DoObject(h:handle):boolean;
const
__Rect = 3;
__PolyObj = 5;
__CurveObj = 21;
begin
__case GetType(h) of
____Rect, PolyObj, CurveObj: MensekiStamp(h);
__end;{case}
__DoObject:= false; { trueにするとForEachObjectループを終了します。 }
end;{DoObject}

begin{main}
__nObj:= 0;
__ForEachObjectInLayer(DoObject, SelectedObjects, TraverseShallow, EditableLayers);
__AlrtDialog(Concat(nObj, '個の図形に面積スタンプを押しました。'));
end;{main}
Run(test);


複数の多角形の面積スタンプ    Go5
Thu Jan 27 9:19:41 2011

与太郎さん 早々のご返答ありがとうございます。
すみません、表現が間違っていました。

図面上にある、複数の図形をすべて選択して、
そのすべての図形の中に、面積を記入する、です。

     ----------------------
良い入門テキストが見つからず、苦戦しています(^j^)


Re:複数の多角形の面積スタンプ    与太郎
Wed Jan 26 23:27:59 2011

>多角形で囲った部分の面積を 一度に全部スタンプしたいのですが、
多角形に囲まれた中の多角形全部、ということでしょうか?
複数選択して、ではダメですか?



複数の多角形の面積スタンプ   GoGo
Wed Jan 26 16:14:14 2011

はじめまして Scriptを勉強しはじめた Go5 ともうします。
まったくの初心者でして、入門書なんかは読んでいるのですが
ラチがあかず 困っています。

私の希望は、”複数の多角形の面積スタンプ”を作りたいのです。
外壁の改修工事なんかで、多角形で囲った部分の面積を 一度に全部
スタンプしたいのですが、むずかしいでしょうか?

以前、談話室にありました ”面積スタンプ”を改良してみまして
今は一つ一つに スタンプしています。

簡単な作業を Scriptにできる事を希望している入門者です。
難しければ あきらめます! それだけでも教えてくだされば
大変助かるのですが、お願いいたします。

環境は VW10 MacX WinXP です。


全レイヤの情報をWSに書き出す。    与太郎
Mon Jan 24 12:53:55 2011

管理人さん御希望のレイヤ名変更の前に、
とりあえずレイヤ情報をワークシートに書き出してみます。
2004年11月のバックナンバーに使えそうなスクリプトがあったので参考にしました。

procedure LayerInfoWS;
{ 全レイヤの情報をワークシートに書き出します。 }
{$ DEBUG}
const
__WSName = 'LayerInfoWS';
__ClmLyrName = 1;
__ClmLyrScale = 2;
__ClmLyrElev = 3;
__ClmLyrTick = 4;
__DefFontName = 'MS ゴシック';
__DefTextSize = 9;
__SQ = Chr(39);{ ' }
var
__hWS, hL__:handle;
__name__:string;
__scl, elev, tick__:real;
__i, nL__:integer;
__formula__:string;
__
__function AddSQ(s:string):string;
__{ 名前の中の「'」を「'」+「'」 に直す。 }
__var
____result__:string;
____i, j, lng__:integer;
__begin
____result:= s;
____lng:= Len(result);
____i:= 1;
____while (i <= lng) do begin
______if Copy(result, i, 1) = SQ then begin
________Insert(SQ, result, i);
________lng:= lng + 1;
________i:= i + 1;
______end;{if}
______i:= i + 1;
____end;{while}
____AddSQ:= result;
__end;{AddSQ}
__
__procedure WriteCell(h:handle; rw, clm:integer; dt:string);
__{ セルに文字列を書き込む。 }
__begin
____SetWSCellFormula(h, rw, clm, rw, clm, dt);
__end;{WriteCell}
__
__procedure WriteWS(h:handle; rw:integer; name:string; scl, elev, tick:real);
__{ WSに一行分のデータを書き込む。 }
__var
____formula__:string;
__begin
____formula:= Concat('=', SQ, AddSQ(name), SQ);
____WriteCell(h, rw, ClmLyrName, formula);
____WriteCell(h, rw, ClmLyrScale, Concat('=', SQ, '1 / ', scl, SQ));
____WriteCell(h, rw, ClmLyrElev, Concat(elev));
____WriteCell(h, rw, ClmLyrTick, Concat(tick));
__end;{WriteWS}
__
__function GetWS(wkSheet:string):handle;
__{ ワークシートのハンドルを返す。(なければ作成する。) }
__const
____WSheet = 18;
__var
____h__:handle;
____row, clm__:integer;
__begin
____h:= GetObject(wkSheet);
____if (h <> nil) & (GetType(h) = 18) then begin
______GetWSRowColumnCount(h, row, clm);
______if (nL+1) < row then
________DeleteWSRows(hWS, nL+1, row-nL-1)
______else if row < (nL+1) then
________InsertWSRows(hWS, row, nL+1-row);
____end{if}
____else begin
______name:= wkSheet;
______i:= 0;
______while (h <> nil) do begin
________i:= i + 1;
________name:= Concat(wkSheet, '-', Num2Str(0, i));
________h:= GetObject(name);
______end;{while}
______h:= CreateWS(name, nL+1, ClmLyrTick);
____end;{else}
____WriteCell(h, 1, ClmLyrName, 'Layer');
____WriteCell(h, 1, ClmLyrScale, 'Scale');
____WriteCell(h, 1, ClmLyrElev, 'Elevation');
____WriteCell(h, 1, ClmLyrTick, 'Tichness');
____GetWS:= h;
__end;{GetWS}
__
begin{main}
__PushAttrs;
__TextFont(GetFontID(DefFontName));
__TextSize(DefTextSize);
__nL:= NumLayers;
__hWS:= GetWS(WSName);
__i:= 0;
__hL:= FLayer;
__while hL <> nil do begin
____i:= i + 1;
____name:= GetLName(hL);
____scl:= GetLScale(hL);
____GetLayerElevation(hL, elev, tick);
____WriteWS(hWS, nL+2-i, name, scl, elev, tick);
____hL:= NextLayer(hL);
__end;{while}
__PopAttrs;
__ShowWS(hWS, true);
end;{main}
Run(LayerInfoWS);

このスクリプトで作成したワークシートの縮尺、レイヤ基面の高さ、レイヤ厚を書き換えて、
一度にレイヤ情報を変更するスクリプトを書くのは簡単でしょう。
レイヤ名を「='レイヤ名'」と記入してるのは、セルに書き込むときに数字と解釈されるのを避けるためです。
たとえば「01」をそのまま書き込むと「1」に変わってしまいます。
AddSQ関数は、レイヤ名に引用符「'」が含まれているときに必要になります。
引用符に囲まれた文字列の中で「'」を使うときは「'」を2つ続けて書く決まりなので、
「No.1'」は、「='No.1''」ではなく「='No.1'''」としなければなりません。
これは、スクリプトに検索条件を書く場合も同じです。
ちなみに、VectorWorksのワークシートでは引用符は「'」ですが、Excelでは「"」が引用符です。


Re5:VW2011で追加された関数/手続き    江戸の黒板当番
Thu Jan 20 10:03:51 2011

こちらの部屋にはあまりお邪魔していない江戸の黒板当番です。
石男さんの目はやはりそこに行きますかね。
とあるところからの情報に因りますと
http://www.odbcmanager.net/
のODBC Managerなるユーティリティソフトが必要だとか
現在、鋭意調査中です。
便利なものと便利なもののエアポケットは大きいですね。


Re4:VW2011で追加された関数/手続き    与太郎
Wed Jan 19 15:33:04 2011

確かに、英語の説明さえほとんどありませんね>Object Events

重要な変更に、
function GetType(h:handle):integer;→廃止
function GetTypeN(h:handle):integer;→新規
というのがありますが、
引数も返り値も同じで名前が違うだけなので、
わざわざ変えた意味が判りません。

>管理人さん
下のRe3を消していただけないでしょうか。
GetTypeとGetObjectを打ち間違えました。


Re2:VW2011で追加された関数/手続き    石男
Tue Jan 18 19:45:14 2011

レファレンスで解説されているものは、普通に使えそうですが...
ODBCに関する解説が一切ありません、残念です。
Object EventsのTool Eventsに関してもほぼ説明がありません、Cを参考に(乏しい知識)で
すが試しても、うまくいきませんでした。
とにかくもっとレファレンスを充実させていただかないと...。


Re:VW2011で追加された関数/手続き    与太郎
Tue Jan 18 10:15:21 2011

個人的には、新しく追加されたObject Eventsが気になります。


VW2011で追加された関数/手続き    与太郎
Tue Jan 18 10:02:00 2011

A&Aのサイトを覗いたら2011の関数/手続き一覧があったので、
2011で追加されたものを書き出してみました。

Criteria
__ComponentArea
__ComponentVolume
__XCoordinate
__YCoordinate
__ZCoordinate

Database / Record
__GetParametricRecord

Dialogs - Modern
__GetPopUpChoiceIndex
__GetTreeControlItemText
__GetTreeControlSelectedItemText
__ShowEditTileDialog
__ShowEditTileSettingsDialog
__ShowNewTileDialog

Document Attributes
__AddTileGeometryObject
__CreateTile
__GetTileBackgroundColor
__GetTileGeometryGroup
__GetTileGroupParent
__GetTileOffsetPoint
__GetTileRepetitionPoint
__IsTileGroupContainedObject
__SetTileBackgroundColor
__SetTileOffsetPoint
__SetTileRepetitionPoint
__GetCurrentPlanarRefID

Object Attributes
__GetEntityMatrix
__SetEntityMatrix

Object Editing
__BeginMultipleDuplicate
__DeleteSymbolDefinition
__EndMultipleDuplicate

Object Events
__GetEvent
__SetCntrlPtVis
__SetObjPropCharVS
__SetObjPropDoubleVS
__SetObjPropVS
__vsoAddParamWidget
__vsoAppendParamWidget
__vsoAppendWidget
__vsoGetEventInfo
__vsoInsertAllParams
__vsoInsertParamWidget
__vsoInsertWidget
__vsoPrmName2WidgetID
__VSOSetEventResult
__vsoSetObjToolName
__vsoStateAddCurrent
__vsoStateClear
__vsoStateGet
__vsoStateGetExitGroup
__vsoStateGetLayrChng
__vsoStateGetNameChng
__vsoStateGetObjChng
__vsoStateGetParamChng
__vsoStateGetPos
__vsoStateGetRot
__vsoWidgetGetEnable
__vsoWidgetGetRecParam
__vsoWidgetGetText
__vsoWidgetGetVisible
__vsoWidgetPopupAdd
__vsoWidgetPopupClear
__vsoWidgetPopupGet
__vsoWidgetPopupGetCnt
__vsoWidgetPopupSet
__vsoWidgetSetEnable
__vsoWidgetSetIndentLevel
__vsoWidgetSetText
__vsoWidgetSetVisible
__vstAddButtonMode
__vstAddPDMenuItem
__vstAddPDMenuMode
__vstAddRadioMode
__vstCustomProcNNA
__vstDefault2DToolDraw
__vstDefault3DToolDraw
__vstDrawCoordArcN
__vstDrawCoordEllipse
__vstDrawCoordLine
__vstDrawCoordLine3D
__vstDrawCoordLineN
__vstDrawCoordLineN3D
__vstDrawCoordRect
__vstEnableMode
__vstGetCurrPt2D
__vstGetCurrPt3D
__vstGetDataLong
__vstGetDataReal
__vstGetDataString
__vstGetEventInfo
__vstGetEventResult
__vstGetInitObject
__vstGetModeHelpBase
__vstGetModeValue
__vstGetPickObject
__vstGetPt2D
__vstGetPt3D
__vstGetRsrcFileID
__vstGetString
__vstGetToolObject
__vstNameUndoEvent
__vstNumPts
__vstRestoreWPHybridTool
__vstSetCursorByView
__vstSetCustomProc
__vstSetDataLong
__vstSetDataReal
__vstSetDataString
__vstSetEventInfo
__vstSetEventResult
__vstSetHelpString
__vstSetModeHelpBase
__vstSetPDMenuSel
__vstSetPtBehavior
__vstSetRsrcFile
__vstSetWPHybridTool

Object Info
__ConsolidatePlanarObjects
__GetObjectVariablePoint
__GetPlanarRef
__GetTypeN
__SetObjectVariablePoint
__SetPlanarRef
__SetPlanarRefIDToGround

Object Names
__GetColorName
__GetDashStyleName
__SetColorName
__SetDashStyleName

Objects - Architectural
__ConvertToUnstyledSlab
__CreateSlab
__CreateSlabStyle
__GetComponentAutoBoundEdgeOffset
__GetComponentFollowBottomWallPeaks
__GetComponentFollowTopWallPeaks
__GetComponentManualEdgeOffset
__GetComponentNetArea
__GetComponentNetVolume
__GetComponentTexture
__GetComponentWallBottomOffset
__GetComponentWallTopOffset
__GetDatumSlabComponent
__GetSlabHeight
__GetSlabPreferences
__GetSlabPreferencesStyle
__GetSlabStyle
__GetWallPreferences
__ModifySlab
__SetComponentAutoBoundEdgeOffset
__SetComponentFollowBottomWallPeaks
__SetComponentFollowTopWallPeaks
__SetComponentManualEdgeOffset
__SetComponentTexture
__SetComponentWallBottomOffset
__SetComponentWallTopOffset
__SetDatumSlabComponent
__SetSlabHeight
__SetSlabPreferencesStyle
__SetSlabStyle
__SlabFromPoly

Objects - Groups
__BeginGroupN

Objects - Text
__SetTextAdorner
__SetTextJustN
__SetTextVertAlignN

ODBC
__DBDocAddConn
__DBDocGetColumns
__DBDocGetConn
__DBDocGetDB
__DBDocGetTables
__DBDocHasConn
__DBDocRemoveConn
__DBDocSetColKey
__DBGetFormatConn
__DBGetFormatFieldConn
__DBObjSQLGetRead
__DBObjSQLGetWrite
__DBObjSQLSetRead
__DBObjSQLSetWrite
__DBSetFormatConn
__DBSetFormatFieldConn
__DBShowDBTableDlg
__DBShowManageDBsDlg
__DBShowObjConnDlg
__DBSQLExecute
__DBSQLExecuteDelete
__DBSQLExecuteDSN
__DBSQLExecuteGet
__DBSQLExecuteNext

Parametric Constraints
__BuildConstraintModelForObject

PlantObjectCoreTools
__Plant_CreateDuplicatePlant
__Plant_EditPlantDefinitionViaResourceBrowser
__Plant_GetToolInitialized
__Plant_GetToolPlacementMode
__Plant_GetToolPlantName
__Plant_GetToolSpacing
__Plant_ReplacePlant
__Plant_ResetPlantInstances
__Plant_UpdatePlacePlantTool
__Plant_UpdateTranslatedPlantIDRecord

SiteModel Interface Library
__DTM6_ClearModelCache
__DTM6_GetDTMObject
__DTM6_GetDTMOver
__DTM6_GetZatXY
__DTM6_IsDTM6Object
__DTM6_IsObjectReady
__DTM6_IsTypeVisible
__DTM6_SendToSurface

Spotlight
__DBeam_Begin
__DBeam_BeginShttGet
__DBeam_End
__DBeam_EndShttGet
__DBeam_Get2DLines
__DBeam_Get2DLn2FOff
__DBeam_Get2DObjAtFs
__DBeam_Get2DObjFOff
__DBeam_Get3DShutter
__DBeam_GetLast2DObj
__DBeam_GetLastObject
__DBeam_GetLines
__DBeam_GetLines2FOff
__DBeam_GetObjAtFocus
__DBeam_GetObjFallOff
__DBeam_SetBeamAngle
__DBeam_SetBeamAngle2
__DBeam_SetBShutAngle
__DBeam_SetBShutDepth
__DBeam_SetFallOffDist
__DBeam_SetFocusPoint
__DBeam_SetLampRot
__DBeam_SetLightOrigin
__DBeam_SetLShutAngle
__DBeam_SetLShutDepth
__DBeam_SetRShutAngle
__DBeam_SetRShutDepth
__DBeam_SetShow3DType
__DBeam_SetShowAtPoint
__DBeam_SetTShutAngle
__DBeam_SetTShutDepth
__DBeam_ShowBeamLines
__LDevice_ClearCache
__LDevice_ExtractCache
__SL_Export
__SL_Import

Textures
__CreatePaintFromImgN
__GetTextureSet
__SetTextureSet

Utility
__GetWorkingPlaneMat
__GetWorkingPlaneN
__IsCoPlanar
__IsPerpPlane
__PlanarPtTo3DModelPt
__PlanarPtToScreenPlanePt
__ScreenPlanePtToPlanarPt
__SetWorkingPlaneN

Worksheets
__AreWorksheetGridLinesVisible
__SetWorksheetGridLinesVisibility

XML
__CreateNewXMLDocument
__DeleteAttribute
__DeleteCDATA
__DeleteElement
__FindAttribute
__FindElement
__GetAttributeValue
__GetCDATA
__GetElementValue
__GetFirstChild
__GetNextElement
__GetPreviousElement
__InitXML
__ReadXMLFile
__ReadXMLMemory
__ReleaseXML
__SetAttributeValue
__SetCDATA
__SetElementValue
__WriteXMLFile
__WriteXMLMemory

XML SAX
__XMLSAXAddNodeAttr
__XMLSAXAddNodeValue
__XMLSAXBeginDocFile
__XMLSAXBeginDocMemory
__XMLSAXBeginNode
__XMLSAXEndDoc
__XMLSAXEndDocMemory
__XMLSAXEndNode
__XMLSAXParseFile
__XMLSAXParseMemory

新機能がたくさん追加されたみたいです。


RE.^9:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    管理人
Fri Jan 14 18:40:13 2011

与太郎さん、ありがとうございます。
プログラミングの醍醐味をかいま見る展開で、ワクワクします。

ワークシート関連は、どうやら管理人のキャパを超えそうです。
管理人は楽するためなら、どんな苦労も厭いませんが、
目前に楽がないので、時期を待つことにします。

あ!
これ、レイヤ名の変更にも応用できますね? あ、的外れ?見当違い?高望み?


RE.^8:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    与太郎
Fri Jan 14 18:29:48 2011

「ガラス」を定数にすれば、文字数(バイト数)を書く必要はありませんでした。
また、文字列長の範囲を超えてCopyすると警告エラーが出るので、先に文字列長を比較する必要があります。
修整したDoObject関数は下のようになります。(「__」は消すかタブに置き換えてください。)

function DoObject(h:handle):boolean;
{ 図形のクラス名を変更する。 }
const
__PartStr = 'ガラス'; { 検索する文字列 }
__PartStrPos = 1; { PartStrが始まるバイト位置 }
__NewClassName = '窓'; { 変更後のクラス名 }
var
__cls :string;
begin
__cls:= GetClass(h);
__if (((Len(PartStr)+PartStrPos-1) <= Len(cls)) & (Copy(cls, PartStrPos, Len(PartStr)) = PartStr)) then begin
____SetClass(h, NewClassName);
____num:= num + 1;
__end;
end;{DoObject}

しかし、よく考えたらPos関数を使ったほうがif文が簡単になります。
「ガラス」が先頭にあれば、Pos関数は1を返します。5byte目からが「ガラス」なら5を返します。

if (Pos(PartStr, cls) = PartStrPos) then begin

上は「ガラス」の位置が何バイト目から始まるか決っている場合です。
クラス名に「ガラス」がないときは、Pos関数は0を返します。
ですからクラス名に「ガラス」を含む場合全てを拾うなら、

if (Pos(PartStr, cls) <> 0) then begin

となります。
複数の単語で調べるなら、

if ((Pos(PartStr1, cls) = PartStrPos) | (Pos(PartStr2, cls) = PartStrPos)) then begin

または、

if ((Pos(PartStr1, cls) <> 0) | (Pos(PartStr2, cls) <> 0)) then begin

です。

>ワークシートについての解説部分が、よく分かりません。
>お手数ですが、もう少し、説明をお願いできますか?
ワークシートで文字列を指定するように直すと元の何倍にも増量するので、
別のレスにしたほうが良いでしょう。
おそらくは別の日に、もしかしたら別の人が。


RE.^7:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    管理人
Fri Jan 14 16:45:39 2011

与太郎さん、早速ありがとうございます。
管理人が望んでいるのは、まさに、角煮さんへのScript
>if (Copy(cls, 1, 6) = 'ガラス') then begin
です。
もし、5byte目から12byteまでの比較なら、数値の書き換えだけで大丈夫なのですか?
>「or」より処理が早いので「|」を
は、まさにベテランならではのTipsですね!

管理人のワイルドカードうんぬんへの解説は、
管理人の知識不足でおかけした、余計なお手間でした。あいすみません。
半角と全角などなど、たしかに泥沼になりそうですね。

ワークシートについての解説部分が、よく分かりません。
お手数ですが、もう少し、説明をお願いできますか?


RE.^6:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    与太郎
Fri Jan 14 15:54:15 2011

>角煮さん
先頭が「ガラス」と判っているなら、1byte目から6byte(全角3文字)を比較すればいいので、if文は
if (Copy(cls, 1, 6) = 'ガラス') then begin
の1行で済みます。
「ガラス」の他に「枠」があれば、
if ((Copy(cls, 1, 6) = 'ガラス') | (Copy(cls, 1, 2) = '枠')) then begin
のようになります。
「|」は「or」と同じ意味ですが、「or」より処理が早いので「|」を使ってます。


>管理人さん
Pos関数で、文字列内の特定の文字列の位置(と有無)が調べられるので、
「ガラス*」で検索して「ガラス」や「ガラス-1」を拾うスクリプトは可能でしょう。
MS-DOSのワイルドカード(*, ?)ならそう難しくなさそうです。
大文字と小文字、半角文字と全角文字まで考慮すると頭が痛くなりそうですが。

下のスクリプトでも、ワークシートの左の列に変更前、右の列に変更後の名前を入れておいて一度
に複数の組み合わせを処理するようにすれば、スクリプトを書き換える必要はなくなります。


RE.^5:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    管理人
Fri Jan 14 15:15:22 2011

与太郎さんの回答Script書き込みが12:11:20 。ありがとうございます。
角煮さんの解決報告が14:43:51。ありがとうございます。
つまり、2時間半でガッツポーズ。
しかも、多分、含むランチ時間、でしょうな。
同じ時間で、管理人は天ぷら蕎麦を食べただけです。
時間は、いくらでも無為に過ごせますです。
では、また一尺降ったので除雪して来ます。偉い?


複数のクラス名を一つのクラス名に一括変換    角煮
Fri Jan 14 14:43:51 2011

与太郎さん・管理人さん

出来ました!!!!!!(一人でガッツポーズしました)


ある物件では、57個の「ガラス」が頭につくクラス名で

また、ある物件では15個ぐらいでした。

わからないので、

(cls = '変更前のクラス名2') |

をコピーし続けました^^”

「ガラス」の他に、数え切れない項目があり、、、

なれるまで、いただいた、このTXTを使い

他の項目もやってみます。

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

ルールなど、失礼があったかと察しますが、

(Script談話室)にこういう文章、御礼

など書いていいのかもわかりませんが、すいません。




RE.^3:複数のクラス名を一つのクラス名に一括変換    管理人
Fri Jan 14 14:31:44 2011

ハンドルの概念が苦手なので、管理人は二の足を踏むのですが、
文字列を扱うコマンドはVectorScriptではどうなのでしょう?
たとえば、左先頭の3文字がガラスで始まり以降の文字列はバラバラ、
つまり、ワイルドカード的に使えると、検索文字列の表記が楽できそうで…
これに、繰り返しのコマンドを組み合わせて、ああ、
ここで管理人のハンドルの理解不足が出て、分からなくなるのですが、
何とかなります?


.:複数のクラス名を一つのクラス名に一括変換    角煮
Fri Jan 14 13:09:23 2011

与太郎さんへ

本当に感激です。

ありがとうございます。

管理人さんの、おっしゃるように「?」ばかりの呪文ですが・・・

メモ帳?とかにコピーし、「階層/コマンド実行」で、やるんですよね?

>「超Script初心者は、このScriptを何処にどうするの?」状態です・・・

バックナンバーでの「検索」が、なかなかたどりつかず・・・

自身でも、少し、さわってやってみます。

まずは、中のクラス名を変えてみます。。

宜しくご指南下さい。




RE.:複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    管理人
Fri Jan 14 12:36:09 2011

わあ、与太郎 さん。あ、管理人です。
これ、いいですねえ。優柔不断で試行錯誤だらけの管理人にはピッタリです。
が、
おそらく、角煮さん(失礼)と超Script初心者は、このScriptを何処にどうするの?
ではないかと思います。
どなたか、古めバージョンと新しめバージョンでの作成手順を御指南頂ければ。
さすれば(古めの言い方)
これまでの膨大な与太郎さんを始めとする猛者連のScriptが生きて来るはず、
と、管理人は考える次第でありおりはべり。


複数のクラス名を一つのクラス名に一括変換(VectorWorks談話室より)    与太郎
Fri Jan 14 12:11:20 2011

下のスクリプトで一度に変換出来ます。
クラス名の部分は書き換えてください。

procedure test;
{ ファイル内の全図形の特定の(複数の)クラスを別の(ひとつの)クラスに変更する。 }
{$ DEBUG}
const
AllObjects = 0;
TraverseDeep = 2;
AllLayers = 1;
var
num :longint;

function DoObject(h:handle):boolean;
{ 図形のクラス名を変更する。 }
var
cls :string;
begin
cls:= GetClass(h);
if ((cls = '変更前のクラス名1') |
(cls = '変更前のクラス名2') | { この行をコピーして追加してください。 }
(cls = '変更前のクラス名n')) then begin
SetClass(h, '変更後のクラス名');
num:= num + 1;
end;
end;{DoObject}

begin{main}
num:= 0;
ForEachObjectInLayer(DoObject, AllObjects, TraverseDeep, AllLayers);{ 全レイヤ、グループ内 }
ForEachObjectInList(DoObject, AllObjects, TraverseDeep, FSymDef);{ シンボル内 }
ReDrawAll;
AlrtDialog(Concat(num, '個の図形のクラスを変えました。'));
end;
Run(test);


丸付き番号のサイズを変えるスクリプト(2)    与太郎
Wed Jan 12 20:02:13 2011

シンボルを別のシンボルに置き換えるには、SetHDef(hSymObj, hNewSymDef); を使います。
レコード情報を維持したまま置き換えてくれるので面倒がありません。
置き換え後のシンボルを作る部分は「丸付き番号を描くスクリプト(4)」から流用できます。
今回は手続きDrawPolyとMakeSymbolの部分をファイルにして参照します。
「procedure DrawPoly.vss」と「procedure MakeSymbol.vss」という名前でVectorWorksフォルダ
に保存してください。

procedure ResizeNumber;
{ 選択した丸付き番号のサイズを変えます(シンボルを置き換えます)。 }
{ サイズと頂点数はワークシート「Number-Def」で設定します。 }
{$ DEBUG}
const
{ 選択図形処理用 }
__SelectedObjects = 2;
__TraverseShallow = 0;
__EditableLayers = 4;
{ 丸付き番号用 }
__WrkSheet = 'Number-Def';
__ParameterRec = 'Number-Rec';
__ClassName = '番号';
__MaxFieldLength = 3; { 最大文字数 }
__TxFont = 'MS ゴシック';
__Center = 2;
__VertCenter = 3;
__DefaultText = 'A';
__DefaultStep = 1;
__DefaultDia = 5{m/m};
__DefaultPoly = 0; { 多角形の頂点の数= -9..-3, 0, 3..9 }
__Red = 15;
__Black = 255;
__PenWidth = 6; { (mil) }
__MaskSize = 1.1; { マスクの倍率 }
__MarkerStyle = 13; { 始点に黒丸 }
__MarkerSize = 0.04; { (inch) }
__MarkerAngle = 0; { (degree) }
__
var
__n__:integer;
__d, r, r2, scl, upi__:real;
__hSymDef__:handle;
__SymNm__:string;
__
__function GetUPI:real;
__{ 書類のUPI(unit par inch)を返す。 }
__var
____uMark, sqUMark__:string;
____frac, dsAcc, format, upi__:real;
__begin
____GetUnits(frac, dsAcc, format, upi, uMark, sqUMark);
____GetUPI:= upi;
__end;{GetUPI}
__
__procedure GetDef(wsName:string; var d:real; var n:integer);
__{ ワークシートから直径、多角形の頂点の数を読み取る。 }
__var
____h__:handle;
__begin
____d:= 0;
____h:= GetObject(wsName);
____if h = nil then
______AlrtDialog(Concat('ワークシート「', wsName, '」がありません。', Chr(13), 'このファイルでは丸付き番号を使ったことがないようです。'))
____else begin
______d:= GetCellNum(h, 3, 2);
______n:= GetCellNum(h, 4, 2);
______SelectSS(h);
____end;
__end;{GetDef}
__
{ 丸付き番号を描くスクリプト(4)から流用 }
{$INCLUDE procedure DrawPoly.vss}
{$INCLUDE procedure MakeSymbol.vss}
__
__function GetRFs(h:handle):string;
__{ 丸番号(シンボル)のレコードフィールドの文字を返す。 }
__{ レコードがない場合は空文字を返す。 }
__var
____result :string;
____i :integer;
__begin
____result:= '';
____for i:= 1 to MaxTextLength do
______result:= Concat(result, GetRField(h, ParameterRec, Concat(i)));
____GetRFs:= result;
__end;{GetRFs}
__
__function DoObject(h:handle):boolean;
__{ 丸番号のサイズを変える(別のシンボルに置き換える) }
__const
____SymbolObj = 15;
__var
____s :string;
__begin
____if (GetType(h) = SymbolObj) & (GetRFs(h) <> '') then begin
______hSymDef:= GetObject(symNm);
______if hSymDef = nil then begin
________{ シンボル生成 }
________PushAttrs;
________NameClass(ClassName);
________TextFont(GetFontID(TxFont));
________TextJust(Center);
________TextVerticalAlign(VertCenter);
________Marker(MarkerStyle, MarkerSize, MarkerAngle);
________MakeSymbol(symNm, r, r2, scl, n);
________PopAttrs;
________
________hSymDef:= GetObject(symNm);
______end;
______SetHDef(h, hSymDef);
____end;
____DoObject:= false;
__end;{DoObject}
__
begin{main}
__GetDef(WrkSheet, d, n);
__scl:= GetLScale(ActLayer);
__upi:= GetUPI;
__r:= d / 2 * scl * upi / 25.4; { 円の半径 }
__r2:= r * MaskSize; { マスクの半径 }
__symNm:= concat('Number(', n, '):', d * scl);
__if r <> 0 then begin
____ForEachObjectInLayer(DoObject, SelectedObjects, TraverseShallow, EditableLayers);
__end;
end;
Run(ResizeNumber);


丸付き番号のサイズを変えるスクリプト(1)    与太郎
Wed Jan 12 10:18:38 2011

シンボル版丸付き番号の欠点は、丸の大きさを自由に変えられないことでしょうか。
別のサイズのシンボルに置き換える以外に方法はありません。シンボル名とサイズが結び付いている
ので、シンボルに入って大きさを変えるのは禁じ手です。
すでにあるシンボルに置き換えるならデータパレットのシンボル置き換えでも良さそうなものですが、
レコード情報が消えてしまうという致命的欠点があるので使えません。
やはりスクリプトを書くしかないのですが、それほど難しくはありません。
(つづく)

↓何を慌てたか訂正レスでレス番号を間違えるという恥の上塗りを演じてしまいましたが、
  これが今年最初の失態でないのが悲しいところ。今年最後でないのは言うまでもないですが。
  というわけで、新年早々ばがやろさまでございました。


Re.2:番号を増減するスクリプト    与太郎
Tue Jan 11 12:54:52 2011

すいません、
↓修正前のスクリプトを書き込んでしまいました。
  {$INCLUDES function NextStr.vss} は、
  {$INCLUDE function NextStr.vss} の間違いです。


番号を増減するスクリプト    与太郎
Fri Jan 7 21:02:40 2011

連番の途中で番号の挿入や削除をすると、あとの番号を増減する必要がありますが、
番号をひとつずつ修正するのは面倒です。
そんなときこそスクリプトの出番です。

procedure ChangeNumbers;
{ 選択した丸付き番号(レコード付きシンボル)の番号を増減する。 }
const
__ParameterRec = 'Number-Rec';
__MaxFieldLength = 3;
__SelectedObjects = 2;
__TraverseShallow = 0;
__EditableLayers = 4;
var
__i, n :integer;

{$INCLUDES function NextStr.vss}
__{ ここにNextStr関数が入ります。 }

__function GetString(h:handle):string;
__{ 丸番号(シンボル)の番号(レコードフィールドの値)を返し、レコードフィールドを消去する。 }
__var
____result :string;
____i :integer;
__begin
____result:= '';
____for i:= 1 to MaxFieldLength do begin
______result:= Concat(result, GetRField(h, ParameterRec, Concat(i)));
______SetRField(h, ParameterRec, Concat(i), '');
____end;
____GetString:= result;
__end;{GetString}
__
__procedure SetString(h:handle; s:string);
__{ 丸番号(シンボル)の番号(レコードフィールドの値)を設定する。 }
__var
____fld :string;
__begin
____if Len(s) < MaxFieldLength then
______fld:= Concat(Len(s))
____else
______fld:= Concat(MaxFieldLength);
____SetRField(h, ParameterRec, fld, s);
__end;{SetString}
__
__function DoObject(h:handle):boolean;
__{ 丸番号(シンボル)の文字(レコード)を書き換える }
__const
____SymbolObj = 15;
__var
____s :string;
__begin
____if GetType(h) = SymbolObj then begin
______s:= GetString(h);
______if s <> '' then begin
________s:= NextStr(s, i);
________SetString(h, s);
______end;
____end;
____DoObject:= false;
__end;{DoObject}
__
begin{main}
__i:= IntDialog('番号の変化分は?', '0');
__if not DidCancel then begin
____ForEachObjectInLayer(DoObject, SelectedObjects, TraverseShallow, EditableLayers);
__end;
end;
Run(ChangeNumbers);

このスクリプトと下のスクリプトのNextStr関数は全く同じものなので、NextStr関数は外部ファイル
参照としました(ずーっと長い書込みが続いてますしね)。
下のスクリプトの function NextStr... 〜 end;{NextStr} までを「function NextStr.vss」という
テキストファイルにして、VectorWorksフォルダに保存してください。
スクリプトコマンドの場合、フォルダを指定しなければVectorWorksフォルダのファイルを参照します。
Ver.12からは、VectorWorksフォルダはアプリケーション用フォルダとユーザー用フォルダの2箇所に
存在するように変わっています。
VectorScriptでは両方のフォルダから読み取り可能ですが、書き込みは全てユーザー用フォルダが対
象です。

それから、本当はレコードフィールドを読む前にGetString関数でレコードの有無を確認すべきですが、
レコードがないシンボルでGetRFieldを実行してもエラーは出ないので、あえて確認はしませんでした。
経験上、レコードがない場合はGetRField関数は空の文字列を返します。