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

Re4:図形の名前の自動入力    マックン
Thu Dec 29 18:29:04 2005

与太郎さん、度々ありがとうございます。
また、丁寧な回答で恐縮いたします。
さて、「VectorScript Function Reference」の「LSActLayer」の説明には
「選択されている最下位の図形のハンドルを返します。」とありますが、実際には、与太郎さんの
説明のように「一番上の選択図形」を認識しているようです。マニュアルの間違いでしょうか。
そもそも「ハンドルを返します。」という記述が理解できずにいましたが、
図形を選択しているという情報をもらうことで、選択されていない状態を「nil」として与えてくれる
というような理解の仕方でよいでしょうか。
参考のスクリプトは大変参考になりました。
勉強の足がかりとして大変貴重なものとなります。ありがとうございます。


これからVectorScriptを始めようという方へ    与太郎
Tue Dec 27 21:32:46 2005

VWフォルダ>「付属マニュアル」>「VectorScript」の中に、VSBeginnersGuide.pdfがあります。
これでVectorScript Guide(英語版しかありません)の内容の8割方は押さえられます。
VSBeginnersGuide.pdfには無くてVectorScript Guideにしか載っていない重要な事項としては、
構造体(Structures)と動的配列(Dynamic Arrays)がありますが、これは日本語に訳したものが、
エーアンドエーのHP>「開発」>「旧バージョン」>「マニュアル和訳」の中にあります。

「MiniPascal」、「VectorScript」でネットを検索すれば、
スクリプトに関する情報は結構見つかります。
入門者向けサイトもいくつかあります。
ただ残念なことに、エーアンドエーのサイトも含めて、ほとんどが中断状態なんですね。


Re3:図形の名前の自動入力    与太郎
Tue Dec 27 21:30:09 2005

SetNameはマニュアルで下のように説明されています。

−−−−−−−−−−−−−−−−−−−−−−−
PROCEDURE SetName(h:HANDLE; name:STRING);

h    HANDLE  図形のハンドル
name  STRING  図形の名前

ハンドルが指す図形の名前を変更します。
−−−−−−−−−−−−−−−−−−−−−−−

ハンドルとはオブジェクト(図形、レイヤ、レコード等)を指し示すものです。
スクリプトで個々の図形にアクセスするにはハンドルを使いこなす必要があります。

図形のハンドルを得る方法は、
FSActLayer, FActLayer等のハンドル取得関数を使う。
GetPtとPickObjectを使い、マウスクリック位置の図形のハンドルを得る。
ForEachObject等で、条件に一致した図形のハンドルをサブルーチンに渡してやる。
等の方法があります。

例として、アクティブレイヤの一番上の選択図形の名前を変えるスクリプトを書いてみます。
(データパレットで出来ることですが)
procedure ChangeObjectName;
var
_objHand_:handle;
_newName, oldName_:string;
begin
_objHand:= LSActLayer;{ Last(=Top) Object Selected in Active Layer }
_if objHand = nil then begin
__AlrtDialog('アクティブレイヤの図形が選択されていません!');
_end
_else begin
__oldName:= GetName(objHand);
__newName:= StrDialog('図形の名前=', oldName);
__if not DidCancel & (oldName <> newName) then begin
___if GetObject(newName) = nil then begin
____SetName(objHand, newName);
___end
___else begin
____AlrtDialog(Concat(newName, 'はすでに使われています!'));
___end;
__end;
_end;
end;
Run(ChangeObjectName);


Re2:図形の名前の自動入力    マックン
Sun Dec 25 18:52:45 2005

与太郎さん ありがとうございます。
私、VectorScriptは、ほとんど素人です。『DoMenuTextByName』はなんとなく使えたのですが、
『SetName(objHand, name);』は、なんとなくでは動かせませんでした。
関数の基本的なことを理解していないので恥ずかしいのですが、「name」は希望の名前にすればいいと思うのですが、「objHand」の部分はどのようなスクリプトにすればよいのでしょうか。
ご指導よろしくお願いいたします。
*蛇足ですが、バックナンバーを目的の単語で検索できると過去の資産をもっと有効に利用できるのですが...。


感謝!    管理人
Sun Dec 25 11:16:00 2005

与太郎さん、お祝いありがとうございます。
plugramer会員、石男会員をはじめとする超古参メンバーに加え、
与太郎会員、masafumi会員、並びに、多数のボランティアの皆さんのおかげで、
最近のScript談話室の、なんと盛況なこと!
かつての閑古鳥カゴの頃が信じられない賑わいです。
管理人は傍観者(それどころか、ある期間のバックナンバーを喪失した厄介者)ですから、感謝あるのみです。
ときどき喫茶室にもおいで下さい。
今回の大雪はいかが? 日本全国雪浸し(湿った雪だから…)のようで、瀬戸内もドカドカ?
ゴンスケ殿はスタッドレスタイヤをすり減らしているようですが…。


Re:図形の名前の自動入力    与太郎
Sat Dec 24 21:33:13 2005

既存の図形に名前を付けるなら
SetName(objHand, name); を使います。

名前付きの図形を生成するなら
NameObject(name); の後で図形を生成します。

既に名前が使われているかどうかは、自分で調べなければなりません。
GetObject(name) でNilが返ってくれば、その名前は未使用です。

SetName、NameObject 共にカテゴリーは「図形の名前(Object Names)」になっています。
VW9まではマニュアルがPDFだったので「名前」で検索すれば簡単にSetNameもNameObjectも探せたのですが、
VW10以降はHTMLに変わったので、マニュアル全体から検索出来ません。
HTML版マニュアルだと、関係ない関数に多数ヒットするのを覚悟して、「Name」で検索するしかありません。
みなさん各自でHTMLを一つのファイルにまとめたり、PDF化するなどの工夫をされているようでが、
何度目かのバージョンアップで挫折することが多いようです。(バックナンバー:Sat Oct 30 20:48:19 2004〜)

一度マニュアル全体を眺めて、どんな関数があるか(できればカテゴリーまで)知っておけば、
今のマニュアルでも使えないこともないではないです。
また、VWファイルをVectorScript形式で書き出したものもスクリプトを書く参考になります。


Re:DoMenuTextByNameでのコマンド名(解決です)    与太郎
Sat Dec 24 21:21:49 2005

>マックンさん
ご報告ありがとうございました。
管理人さんに(勝手に)成り代わり、お礼を申し上げます。

>管理人さん
新装開店おめでとうございます。
これからもお世話になります。どうぞよろしくお願いします。


図形の名前の自動入力    マックン
Sat Dec 24 15:28:06 2005

続けて質問させてください。
データパレットのレコードでオブジェクトに名前を付けられますが、
既に決まっている名前をスクリプトで図形に与えたいのですが、どんな関数を使えばよいでしょうか。
「SetRecord」を見つけたのですが、違うようですね。
よろしくお願いいたします。
 また、A%A社のHPのVectorScript ドキュメントで『MiniCAD プログラミング入門』という
書籍を紹介していますが、入手可能なところをご存知でしたら、お知らせください。
お願いいたします。


DoMenuTextByNameでのコマンド名(解決です)    マックン
Sat Dec 24 15:14:21 2005

石男さん、与太郎さん ありがとうございます。
開発元に質問してみました。一度目の回答は、マニュアル通りの「自分で勉強しなさい」という回答でしたが、
コマンド名が知りたいだけだと苦情のメールを送ったら、やっと回答がありました。
公開しても問題ないと思うので、お知らせします。
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
SHADOW、VOLUMEのメニューコマンドはプラグインとして付加されているものですので、
VectorWorksアプリケーションフォルダ内「Plug-Ins」フォルダにインストールされ
ているプログラムのファイル名をsubMenuパラメータに渡してご利用ください。

メニュー名:ファイル名のリストは以下の通りです。

地域...:EX-Shadow/Volume[Area]
日影計算条件設定...:EX-Shadow[Setting]
真北方向...:EX-Shadow/Volume[SetDirection]
等時間日影図描画指定...:EX-Shadow[SetPalette]
日影計算実行:EX-Shadow[doShadow]
等時間日影図作成:EX-Shadow[plyShadow]
地点日影計算実行:EX-Shadow[pntShadow]
スムージング...:EX-Shadow[Smoothing]
建物の高さ変更...:EX-Shadow[SetHeight]
日影測定線作成:EX-Shadow[MakeLine]
日影計算条件一覧表:EX-Shadow[MakeReport]

逆日影計算条件...:EX-Volume[Setting]
カラー...:EX-Volume[SetColors]
階高...:EX-Volume[SetFloor]
容積計算実行...:EX-Volume[DoCalc]
逆日影測定線描画...:EX-Volume[WatchLine]
等高線描画:EX-Volume[MakeContour]
面積表:EX-Volume[MakeAreaTable]
逆日影計算条件一覧表:EX-Volume[MakeReport]
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
コマンド名に「EX-」と記されていますが、最新の「A&A Shadow/Volume」で動作を確認できました。
皆さんも、ご活用ください。


Script談話室を引っ越しました    管理人
Tue Dec 20 0:47:20 2005   

ここは新装開店のScript談話室でございます。
まだ、不都合の生じる恐れがありますが、開店を強行します。
お気づきの点をご一報頂けると有難いです。
あ、くれぐれも「送信ボタン」のクリックは一度だけにして下さい。
(やや長押し気味にプレスすると書き込みが反映されるような気がしますが…まさかねぇ)
書き込みが反映されない場合は、もう一度、左の「メニュー」で「Script談話室」をクリックして下さい。
または、ブラウザの「リロード(更新・再読み込み)」ボタンを使って下さい。
最終手段は、「フレームを別ウィンドウで開く」してから「リロード(更新・再読み込み)」です。


Re.2: DoMenuTextByNameでのコマンド名   与太郎
email:  Sun Dec 11 19:50:35 2005

>マックンさん
>DoMenuTextByNameでコマンドを実行させたいのですが、
>日影関係のコマンド名の情報はどこで知ることができるでしょうか。

>石男さん
>DoMenuTextByName等で使えるコマンド名はVW標準のものに限られていますよ。

自作のプラグイン・メニューでもDoMenuTextByNameで実行出来るので、
「プラグイン・コマンド...」のリストで目的のメニューコマンドが見つかれば、
その名前で実行できると思います。
ただし、メニューコマンドの名前はメニューに表示される名前と同じとは限らないので、
どれが目的のメニューコマンドか判らないかもしれません。

メニューコマンドがSDKで作ってある場合は、プラグインのリストには表示されないようです。
チャンクメニューはVectorScriptでは作れないので、必ずSDKで作ってあります。
試しにRenderWorksのメニューコマンドをDoMenuTextByNameで実行しようとしてみましたが、
やはりコマンド名が判らず、出来ませんでした。

それらしいメニューコマンドがなかったら、開発元にお尋ねになってはいかがでしょうか。

いちいちコマンド名を調べるのは面倒なので、ツールマクロみたいにスクリプトを自動生成して
くれるコマンドがあれば助かるんですけどね。


2点間内の連続寸法   石男
email:  Sun Dec 11 14:23:08 2005

施工図を書いていると寸法線を連続で書くことが多いのですが、そんな時全てのポイン
ト指示するのが面倒なのでこんな物を作りました。1点目、2点目を指示してこれを仮の
直線として、この直線に交わる直線と四角形の辺の交点に寸法線を書いていくものです。やはり、自分専用かな?
Procedure Point2AutoDim ;
Label
999 ;
Var
p0 , p1 , p2 , p3 , p4 , p5 , sectpt : Point ;
parallel, intOnLines : Boolean ;
h : Handle ;
i , End_i , myType , horizonal : Integer ;
sect_array : DYNARRAY[ ] of Point ;
sectX_array , sectY_array : DYNARRAY[ ] of Real ;

{=================Main===================}
Begin
PushAttrs ;

GetPt( p0.x , p0.y ) ;
GetPtL( p0.x , p0.y , p1.x , p1.y ) ;

If ( ( p0.x = p1.x ) & ( p0.y <> p1.y ) ) Then
Begin
horizonal := 2 ;{ 垂直}
End Else
If ( ( p0.x <> p1.x ) & ( p0.y = p1.y ) ) Then
Begin
horizonal := 1 ;{ 水平}
End Else
Begin
SysBeep ;
AlrtDialog( '指示した2点が斜めになっています、水平もしくは垂直になるよう指示して下さい。' ) ;
GoTo 999 ;
End ;

h := FActLayer ;

ALLOCATE sect_array[ 1..2000 ] ;
i := 0 ;

Repeat
myType := GetType( h ) ;
If ( ( myType = 2 ) or ( myType = 3 ) ) Then
Begin
Case myType of
2 : Begin
GetSegPt1(h , p2.x , p2.y ) ;
GetSegPt2( h , p3.x , p3.y ) ;
LineLineIntersection( p0 , p1, p2 , p3 , parallel , intOnLines , sectpt ) ;
If ( ( parallel = false ) & ( intOnLines = true ) ) Then
Begin
i := i+1 ;
sect_array[ i ] := sectpt ;
End ;
End ;
3 : Begin
GetBBox( h , p2.x , p2.y , p3.x , p3.y ) ;
p4.x := p3.x ; p4.y := p2.y ;
p5.x := p2.x ; p5.y := p3.y ;
LineLineIntersection( p0 , p1, p2 , p4 , parallel , intOnLines , sectpt ) ;
If ( ( parallel = false ) & ( intOnLines = true ) ) Then
Begin
i := i+1 ;
sect_array[ i ] := sectpt ;
End ;
LineLineIntersection( p0 , p1, p2 , p5 , parallel , intOnLines , sectpt ) ;
If ( ( parallel = false ) & ( intOnLines = true ) ) Then
Begin
i := i+1 ;
sect_array[ i ] := sectpt ;
End ;
LineLineIntersection( p0 , p1, p4 , p3 , parallel , intOnLines , sectpt ) ;
If ( ( parallel = false ) & ( intOnLines = true ) ) Then
Begin
i := i+1 ;
sect_array[ i ] := sectpt ;
End ;
LineLineIntersection( p0 , p1, p5 , p3 , parallel , intOnLines , sectpt ) ;
If ( ( parallel = false ) & ( intOnLines = true ) ) Then
Begin
i := i+1 ;
sect_array[ i ] := sectpt ;
End ;
End ;

End ; { End of Case }
End ;
h := NextObj( h ) ;
until h = nil ;
End_i := i ;
ALLOCATE sect_array[ 1..End_i ] ;

Case horizonal of
1 : Begin
ALLOCATE sectX_array[ 1..End_i ] ;
i := 0 ;
Repeat
i := i +1 ;
sectX_array[ i ] := sect_array[ i ].x ;
until i = End_i ;
SortArray( sectX_array , End_i , 1) ;

{ 寸法線を描く }
i := 0 ;
Repeat
i := i+1 ;
LinearDim( sectX_array[ i ] , p0.y , sectX_array[ i+1 ] , p0.y , 0 , 0 , 771 , 771 , 0.412 ) ;
until i = End_i-1 ;
End ;
2 : Begin
ALLOCATE sectY_array[ 1..End_i ] ;
i := 0 ;
Repeat
i := i +1 ;
sectY_array[ i ] := sect_array[ i ].y ;
until i = End_i ;
SortArray( sectY_array , End_i , 1) ;

{ 寸法線を描く }
i := 0 ;
Repeat
i := i+1 ;
LinearDim( p0.x , sectY_array[ i ] , p0.x , sectY_array[ i+1 ] , 0 , 1 , 771 , 771 , 0 ) ;
until i = End_i-1 ;
End ;
End ; { End of Case }
999 :
PopAttrs ;
End ;
Run( Point2AutoDim ) ;


Re.: DoMenuTextByNameでのコマンド名   石男
email:  Sun Dec 11 14:11:50 2005

DoMenuTextByName等で使えるコマンド名はVW標準のものに限られていますよ。
ちなみにVSFunctionReference(HTML)の中にAdditional VectorScript Resourcesがあり
ます、その中に使えるメニュー等が書いてあります。



DoMenuTextByNameでのコマンド名   マックン
email:
okmoyos@yahoo.co.jp  Sat Dec 10 16:55:21 2005

はじめまして。
DoMenuTextByNameでコマンドを実行させたいのですが、
日影関係のコマンド名の情報はどこで知ることができるでしょうか。
よろしくお願いいたします。


Re:指定シンボル選択  DON
email:  Thu Dec 8 16:27:35 2005

レスありがとうございます。
漢字を色々変更したところ選択できる漢字と
出来ない漢字があることがわかりました。
一応シンボル名を変更して使いたいと思います。
ありがとうございました。


Re:指定シンボル選択   与太郎
email:  Thu Dec 8 15:33:30 2005

>DONさま、
下のほうに、漢字のクラス名が検索されないことがある、という話題がありました。
シンボル名を半角英数字に直したら選択出来ませんか?


指定シンボル選択   DON
email:  Wed Dec 7 14:52:01 2005

だれかわかるかた教えていただきたいのですが
画面上にある指定シンボルをすべて選択したいのですが
以前(ver10)でつかっていたコマンドですと
できたのですが、11をつかってからできないんです。

以前つかったコマンド
SelectObj((S='シンボルの名前'));

どのようにすればいいでしょうか??
よろしくお願いします。


Re^7:円と曲線の違い  hech
email:  Sun Dec 4 21:48:45 2005

>石男さん
励ましありがとうございます。
めげずに頑張ります。

>与太郎さん
詳しい解説ありがとうございます。
桁落ちという現象内容が、よく分かりました。
回避方まで伝授していただきほんとにありがとうございます。
今後この辺も頭に入れてスクリプト作成に励みたいと思います。

皆さん大変長々とありがとうございました。


Re^6:円と曲線の違い   与太郎
email:  Thu Dec 1 17:42:30 2005

何故、円でなく曲線が生成されるのか。

半径が1.2mの円を描くとき、たとえば下のような場合、
x1 = 200.0
x2 = 202.4
y1 = 1000.0
y2 = 1002.4
この座標をを2進数で表すと、下のようになります。
x1 = 11001000
x2 = 11001010.011001100110011001100110011001100110011001
y1 = 1111101000
y2 = 1111101010.0110011001100110011001100110011001100110
0.4は2進数では割り切れないので循環小数になりますが、ここでは有効桁数を50桁にしています。
これを元にdx(=x2-x1)とdy(=y2-y1)を計算すると、
dx = 10.011001100110011001100110011001100110011001
dy = 10.0110011001100110011001100110011001100110
となり、有効桁数が少なくなってしまいます。
これは桁落ちという現象で、近い数字どうしで減算をするときに発生します。
dxとdyで有効桁数が違うのは、それぞれの座標が約200と約1000で違うせいです。
hechさんの例も、有効桁数の違いでdx=dyとならず、正円ではなく長円(曲線)が生成されたと考
えられます。
最下位数桁が変な数字になっているのも、桁落ちしたものを10進数に変換しているためでしょう。

(0, 0)を中心にして円を描いた後で所定の位置に移動すれば、この現象は回避できるはずです。

ちなみに、VW8.5までは座標値が32ビット整数なので、このような現象はありません。


Re^5:円と曲線の違い   石男
email:  Thu Dec 1 16:56:10 2005

円と曲線、これが一番厄介な問題だったりします、今まだの経験上...。
めげずに、続けてください...。


Re^4:円と曲線の違い   与太郎
email:  Wed Nov 30 9:30:39 2005

R>他に四角を普通に書いて、単位設定の桁を上げていくと端数が出てくるのです。
浮動小数点データの丸め誤差のようです。
VW11.5ならArcByCenterを試してみてください。


Re^3:円と曲線の違い  hech
email:  Wed Nov 30 0:52:41 2005

レス遅くなりましてすみません。
>与太郎さん
Arc(x-0.05,Y+0.05,x+0.05,y-0.05,0,360);
上記のような感じで、指令したのですが、やっぱりだめでした。

他に四角を普通に書いて、単位設定の桁を上げていくと端数が出てくるのです。
(下10桁目が1〜3位ずれる。)
しかも四角のサイズを直接数値入力しても下10桁目が端数になってしまいます。
スクリプトが原因ではなさそうですが、何かわかりますか?

>石男さん
小技の利いたコードありがとうございます。
テストに一部使わせていただきました。

色々面倒なことになってしまいましたが、よろしくお願いします。


Re^2:円と曲線の違い   石男
email:  Sat Nov 26 16:14:08 2005

蛇足ですが、ArcByCenterでは描いた円弧のハンドルが取れないバグがあります。
以下、バウンディングボックスでの指定は嫌だと言う人のための中心座標値、半径、
開始角度、角度で円弧を描くサブルーチンです。

Procedure Test ;
{$DEBUG}
{********中心座標値、半径、開始角度、角度で円弧を描く*******}
Procedure CenterArc( c_x , c_y , myR , startAngle , arcAngle : Real ) ;
Begin
Arc( c_x- myR , c_y-myR , c_x+myR , c_y+myR , startAngle , arcAngle ) ;
End ;
{=================Main===================}
Begin
CenterArc( 0 , 0 , 50 , 0 , 30 ) ;
ReDraw ;
End ;
Run( Test ) ;


Re:円と曲線の違い   与太郎
email:  Sat Nov 26 12:49:09 2005

Arc(x1, y1, x2, y2, 0, 360); の、
bounding boxの縦横寸法(x2-x1、y1-y2)が微妙に違うのではないでしょうか。
単位設定の桁数を上げて、生成した図形の大きさを確認してください。


円と曲線の違い  hech
email:  Sat Nov 26 2:13:14 2005

たびたび申し訳ありません。
また質問させてください。
最近会社でVW11.5を購入したのですが、9.5で作ったスクリプトで、
Arcで円を書くコードなのですが、結果が曲線になってしまいます。
9.5では問題ないのですが、11.5では曲線になってしまいます。
何かパラメータ設定が必要なのでしょうか?。
よろしくお願いします。


Re6:図形の均等配置  hech
email:  Mon Nov 21 23:02:55 2005

大変勉強になりました。
dynarrayの件も大変助かります。
適当にサバ読んで、30にしてました。
希望のスクリプト完成までは、まだまだですが頑張ります。

また何かありましたらこの掲示板に書き込み
させていただきます。
ありがとうございました。


Re5:図形の均等配置   与太郎
email:  Mon Nov 21 12:58:26 2005

>はじめに'枠'なんて漢字を使う私もおかしいと気が付けって感じですが、
>アルファベットにするのが、普通ですよね!。
漢字のほうが判り易いけれど、半角英数字のほうがトラブルが少ないです。
今回のようにエラーが出ないと、原因を見つけにくいのでやっかいです。

>コードの始めのTYPEの宣言をもう1つ宣言することは、できるのでしょうか?。
定数や変数の定義と同じく、XXX=structure 〜 end; を好きなだけ書けます。
自分で定義した構造体を、別の構造体の要素にも出来ます。

>d :Array[1..30] of arcInfo;
テストコードだからこうしているだけかも知れませんが、
配列の定義を d:DynArray[] of arcInfo; として、
criteria:= 'LOC=''Waku''';
n:= Count(criteria);
Allocate d[1..n];
ForEachObject(GetArc, criteria);
とすれば、必要なサイズの配列を確保出来ます。


Re4:図形の均等配置  hech
email:  Sat Nov 19 23:42:59 2005

>与太郎さん
検証ありがとうございます。
名前に落とし穴があったとは、全く気付きませんでした。

はじめに'枠'なんて漢字を使う私もおかしいと気が付けって感じですが、
アルファベットにするのが、普通ですよね!。
月曜に会社で、確認してみます。

それと前に書き込んだコードの始めのTYPEの宣言を
もう1つ宣言することは、できるのでしょうか?。
Arcinfo・Rectinfoと設定したいのですが・・・。

くれくれ君で申し訳ありませんが、よろしくお願いします。


Re3:図形の均等配置   与太郎
email:  Sat Nov 19 16:35:35 2005

hechさん、地雷を踏んだようです。
最初はGetArc(GetArcは組込み手続き)が原因かと思いましたが、名前を変えてもForEachObjectは素通りされました。
それで今度は範囲図形の名前を「waku」に変えたら動きました。
でも「境界」でも動いたので、漢字が全てダメなわけではないです。特定の文字コードの問題でしょう。
それから、名前の上書きは問題ないようです。(元の手続きが使えなくなるだけ)


Re:図形の均等配置  hech
email:  Sat Nov 19 10:56:25 2005

>与太郎さん
ヒントを参考に簡易的なものを作ってみたのですが、
DEBUG画面で見て、希望の図形のハンドルが取得できないようです。
範囲図形の'枠'を作成
ForEachobjectでハンドル取得
の予定ですが、文法などいたらないところが多々ありますが、
見ていただけるとうれしいです。


procedure A;
type
arcInfo = structure
x, y, x2, y2 :real;
h :handle;
end;
var
haniX1,haniX2,haniY1,haniY2:real;
hanih :string;
i :longint;
d :Array[1..30] of arcInfo;
procedure GetArc(h:handle);
begin
i := i + 1;
GetBBox(h, d[i].x, d[i].y, d[i].x2, d[i].y2);
d[i].h := h;
end;{GetArc}

begin{main}
{$debug}
haniX1 := 2;
haniX2 := 3;
haniY1 := 25;
haniY2 := 24;
NameObject('枠');
rect( haniX1, haniY1, haniX2, haniY2 );
ForEachObject(GetArc, (LOC='枠'));
end;
run(A);

結果は、変数dに'枠'のハンドルが入力されて終了します。
サブルーチンが悪いのかわかりませんが、指導よろしくお願いします。


Re:図形の均等配置   与太郎
email:  Fri Nov 18 9:05:18 2005

>円が範囲内にあるか判定
ForEachObject(サブルーチン, (LOC='領域図形の名前'));で中心が領域図形内にある図形を処理できます。
処理範囲は全レイヤになります。
中心でなく、円全体が入っている必要があるなら、領域図形を半径分内側にオフセットすればいいです。

>細い範囲内で均等に配置
円を1列に並べるなら簡単。そうでないなら難しいです。


図形の均等配置  hech
email:  Thu Nov 17 23:55:45 2005

石男さん、与太郎さんレスありがとうございます。

>石男さん
>2、各レイヤでの範囲内にある図形の判定(どこまでが範囲内かを自分で決めておく)
この辺のヒントをもう少しほしいのですが、ひとつのレイヤーに数千以上の同じ大きさの
円弧で書いた円がある中で、必要な範囲内の図形のハンドルの取得したいのです。

>与太郎さん
>最終的にどう並べたいかが判らないと雲を掴むような話です。
説明不足ですみません。
上にも書いたのですが、同じ大きさの円弧(Arc)で書いた円が数千以上あるレイヤー
を2つ重ねた状態(数千の位置関係はランダムです。)これを細い範囲で区切り
その中にある円の数をカウントして区切りの中で均等に配置しようと思っています。
しかしスキル不足で、石男さんのコメントしていただいた
>2、各レイヤでの範囲内にある図形の判定
のところで、詰まっています。この辺を詳しくご教授いただけるとうれしいのですが・・・。

たびたび申し訳ありませんが、よろしくご教授お願いします。



Re.2:はじめまして。(図形の均等配置)   与太郎
email:  Thu Nov 17 20:52:59 2005

>hechさん
「範囲内の図形を均等配置」では説明不足でしたね。
図形が最初はどのような状態で、最終的にどう並べたいかが判らないと雲を掴むような話です。
「均等」も(図形が同サイズでない限り)ピッチと隙間のどちらを同じにするかで違います。
どちらにしても構造体の配列、GetBBox、SortArrayを使うんだと思いますが。

ちなみにVWの整列コマンドの均等配置オプションでは、2次元の均等配置は想定外みたいです。


Re.: はじめまして   石男
email:  Thu Nov 17 17:58:48 2005

>hechさん、出来れば題名は質問内容を...。
出来ますが、かなり面倒です。
1、範囲の設定
2、各レイヤでの範囲内にある図形の判定(どこまでが範囲内かを自分で決めておく)
3、範囲内の図形のみ均等に配置(どのような配置にするかは自分で決めておく)
大雑把な流れはこんなもんです。勉強がてら挑戦してみては...。


はじめまして。  hech
email:  Thu Nov 17 0:03:01 2005

hechと申します。
いつも参考に見学させていただいています。
会社でVW9.5を使用しています。

早速ですが質問させてください。
ある範囲内(計算で算出した範囲)にある複数レイヤーに存在する図形を
均等に並べなおしできるでしょうか?

なにぶんスクリプト初心者なので、よろしくお願いします。


シンボルの反転状態を調べる。   与太郎
email:  Mon Oct 24 12:59:12 2005

以前、シンボルの反転状態を調べる方法がないと書きましたが、よく調べたらIsFlipped関数、ま
たは検索条件のIsFlippedで反転状態を調べることが出来ました。
選択したシンボル図形の反転状態は、

if IsFlipped((T=SYMBOL)&(SEL=TRUE)) <> 0 then
_Message('シンボルは反転している。')
else
_Message('シンボルは反転していない|シンボルではない|選択図形がない。');

で調べられます。
ただし、ゼロ以外の値が返っても反転しているのが調べたいシンボル図形とは限りません。
編集が出来ないレイヤ上の選択シンボルが反転していてもゼロ以外が返ってきます。
事前にDSelectAll;を実行するなりして、全レイヤの図形を選択解除してから図形を選択しないと
いけません。
また、複数の選択シンボル図形の選択状態を1個づつ調べるには別の方法が必要です。
選択図形のハンドルを全部保存して1個づつ選択して調べてもいいですが、汎用性を考慮して、
IsFlippedSymbol関数を作ってみました。

特定の図形だけを検索対象にするためには図形の名前を検索条件にしました。ほとんどの場合図形
に名前は付いていないので、一時的な名前を付けて検索します。名前があるときは保存しておいて、
最後に名前を元に戻します。ただし、SetNameで'none'をセットしても無視されるので、元の名前
が'none'だった場合は図形の名前は消えてしまいます。

procedure test;
var
_h_:handle;

function IsFlippedSymbol(h:handle):boolean;
{ シンボルの反転状態を返す。 }
{ ハンドルのチェックは行っていない。 }
{ 図形の名前が'none'の場合、名前が消える。 }
const
_SQ = Chr(39);{'}
_TempName1 = 'Flipped Symbol?';
_TempName2 = 'Flipped Symbol??';
var
_result_:boolean;
_nm, tmpNm, criteria_:string;
begin
_nm:= GetName(h);
_if nm <> TempName1 then
__tmpNm:= TempName1
_else
__tmpNm:= TempName2;
_SetName(h, tmpNm);
_criteria:= Concat('N=', SQ, tmpNm, SQ);
_if IsFlipped(criteria) = 0 then begin
__result:= false;
_end
_else begin
__result:= true;
_end;
_DelName(tmpNm);_{ VW9以降はこの行を削除可能 }
_if (nm <> '') & (nm <> 'none') then_{ VW9以降はこの行を削除可能 }
__SetName(h, nm);
_IsFlippedSymbol:= result;
end;{IsFlippedSymbol}

begin{test}
_h:= FSActLayer;
_Message('Flip = ', IsFlippedSymbol(h));
end;{test}
Run(test);


'none'(nanoぢゃないよ)の謎   与太郎
email:  Wed Oct 19 8:06:39 2005

関数:GetName(h)を使うと図形に付けた名前を調べられます。
名前を付けてなければ''(ヌル)が返ってきます。
ところが名前を消した図形では''でなく'none'が返ってきます。
それでは'none'という名前を付けるとどうなるかというと、'none'が返ってきます。
これでは名前が無いのか'none'なのか区別が付きません。
早い話、'none'という名前は付けないほうがいいということです。(言わなくても誰も付けないって?)

英語版では'一般'クラスが'none'なので、図形には'none'という名前は付けられません。
そういえば、グループ化するとグループのクラスが'一般'になるのは解かりにくいですが、
グループ自体には実体がないので'none'クラスになる(=クラスが無い)というのは理屈に合ってます。
今からでも「一般」を「'無し」や「未設定」に変えてみましょうか(ウソ)。

(注意:VW11からはグループはアクティブ・クラスになるように変更されました。)


寸法をアクティブ・クラスで描く   与太郎
email:  Wed Oct 12 22:02:21 2005

古いバージョンのVWでは、寸法を描くと必ず「寸法」クラスになってしまいます。
ツールマクロを改造して、描いた寸法をアクティブ・クラスにするスクリプトを作ってみます。

寸法ツールを選択して、「階層」−「ツールマクロ...」を実行し、
項目の内「ツール」だけをチェックしてツールマクロを作ります。
Alt/Optionキーを押しながら出来たコマンドをダブルクリックすると、スクリプトエディタが開きます。
下のようなスクリプトが自動生成されています。

Procedure CustTool;
VAR
Name:STRING;
Result:BOOLEAN;
BEGIN
PushAttrs;
CallTool(-210);
PopAttrs;
END;
Run(CustTool);

変数 Name, Result は未使用です。
ツール番号の-210は縦横寸法です。斜め寸法なら-211になります。
下のように SetClass の行を追加すると寸法はアクティブ・クラスに設定されます。
アクティブ・クラスに関係なく「一般」クラスにしたければ、
SetClass(LSActLayer, ActiveClass); でなく SetClass(LSActLayer, '一般'); と入れます。

Procedure CustTool_1;
{ 寸法をアクティブ・クラスで描く }
BEGIN
PushAttrs;
CallTool(-210);
SetClass(LSActLayer, ActiveClass);
PopAttrs;
END;
Run(CustTool_1);

上のスクリプトだと、連続寸法で描いた場合は、最後の寸法以外は「寸法」クラスのままになります。
描いた寸法全部をアクティブ・クラスに設定するには、下のようにします。

Procedure CustTool_2;
{ 寸法をアクティブ・クラスで描く }
VAR
h:handle;
BEGIN
PushAttrs;
CallTool(-210);
h:= LSActLayer;
while h <> nil do begin
SetClass(h, ActiveClass);
h:= PrevSObj(h);
end;{while}
PopAttrs;
END;
Run(CustTool_2);

このままだと、寸法を一つ描く度にスクリプトを実行しないといけません。
repeat と until LSActLayer = nil; を追加すると、連続して寸法を描けます。

Procedure CustTool_3;
{ 寸法をアクティブ・クラスで描く(連続) }
VAR
h:handle;
BEGIN
PushAttrs;
repeat
CallTool(-210);
h:= LSActLayer;
while h <> nil do begin
SetClass(h, ActiveClass);
h:= PrevSObj(h);
end;{while}
until LSActLayer = nil;
PopAttrs;
END;
Run(CustTool_3);


シンボルを拡大縮小する(3)   与太郎
email:  Wed Oct 12 13:03:43 2005

今のままだと、回転も伸縮もシンボルの中心を基点にしてしまうので、シンボルの挿入点がシンボル
の中心からずれていると、伸縮後に挿入点が移動してしまいます。
シンボル挿入点を移動させないためには、最初にシンボル挿入点の位置に基準点を打っておき、後で
グループ図形を元の位置に移動します。

procedure ScaleSymbol_3;
{ シンボルを拡大縮小する }
const
_SymbolObj = 15;
var
_h, hLocus_:handle;
_x0, y0, x, y, rot_:real;
begin
_h:= FSActLayer;
_if (h <> nil) & (GetType(h) = SymbolObj) then begin
__DSelectAll;
__GetSymLoc(h, x0, y0);
__SetSelect(h);
__rot:= GetSymRot(h);
__Locus(x0, y0);
__hLocus:= LNewObj;
__Rotate(-rot);
__DoMenuTextByName('Symbol to Group', 0);
__DoMenuTextByName('Scale Objects', 0);
__Rotate(rot);
__GetLocPt(hLocus, x, y);
__MoveObjs(x0-x, y0-y, false, false);
__DelObject(hLocus);
_end
_else begin
__AlrtDialog('アクティブレイヤのシンボル図形を選択してください!');
_end;
end;
Run(ScaleSymbol_3);


シンボルを拡大縮小する(2)   与太郎
email:  Sun Oct 9 22:37:46 2005

>XとYの倍率が同じなら、問題なく使えるはずです。
シンボルが回転していてXとYの倍率が異なると、形状が歪んでしまいます。
歪まないようにするために、一旦シンボルを水平に戻して、伸縮後に元通り回転させます。

procedure ScaleSymbol_2;
{ シンボルを拡大縮小する }
const
_SymbolObj = 15;
var
_h_:handle;
_rot_:real;
begin
_h:= FSActLayer;
_if (h <> nil) & (GetType(h) = SymbolObj) then begin
__DSelectAll;
__SetSelect(h);
__rot:= GetSymRot(h);
__Rotate(-rot);
__DoMenuTextByName('Symbol to Group', 0);
__DoMenuTextByName('Scale Objects', 0);
__Rotate(rot);
_end
_else begin
__AlrtDialog('アクティブレイヤのシンボル図形を選択してください!');
_end;
end;
Run(ScaleSymbol_2);

これでシンボルが回転していても大丈夫です。


シンボルを拡大縮小する(1)   与太郎
email:  Fri Oct 7 13:15:47 2005

>幻のバックナンバーより
Q: シンボルを拡大縮小できますか?
A: 出来ません。一旦グループ図形に変換してから伸縮してください。

これをスクリプトでやるのは簡単です。2行のスクリプトで実現できます。

DoMenuTextByName('Symbol to Group', 0);
DoMenuTextByName('Scale Objects', 0);

エラーチェックをすると下のようになります。

procedure ScaleSymbol_1;
{ シンボルを拡大縮小する }
const
_SymbolObj = 15;
var
_h_:handle;
begin
_h:= FSActLayer;
_if (h <> nil) & (GetType(h) = SymbolObj) then begin
__DSelectAll;
__SetSelect(h);
__DoMenuTextByName('Symbol to Group', 0);
__DoMenuTextByName('Scale Objects', 0);
_end
_else begin
__AlrtDialog('アクティブレイヤのシンボル図形を選択してください!');
_end;
end;
Run(ScaleSymbol_1);

アクティブレイヤのシンボル図形を選択して上のスクリプトを実行すると「伸縮...」ダイアログが開
くので、倍率を設定してください。
XとYの倍率が同じなら、問題なく使えるはずです。


補足:AppleScriptに埋め込むタイプ   石男
email:  Sat Sep 24 12:04:51 2005

これはMacな人限定の話です...。
AppleScriptについての詳細は他のWeb上のサイトを参考にしてください。
まあ、こんな感じで埋め込みます。

tell application "VectorWorks"
DoScript "Procedure Test ;
Begin
SysBeep;
End;
Run(Test) ;"
end tell
tell application "VectorWorks"でVWに指示を出します。バージョンが違っていても
"VectorWorks"ですので注意が必要です。実際にはVWをアクティブにして置きます。
「DoScript" "」でVectorScriptを走らせます。ダブルクォーテーションの間にVSを
埋め込みます。で最後にend tellでVWを終わりにします。


スクリプトを実行する   与太郎
email:  Thu Sep 22 22:21:26 2005

VW談話室のほうでスクリプトの実行方法について質問がありましたので、こちらに書きます。

スクリプト、マクロ、コマンド、プログラムと呼び方はバラバラですが、全部同じものです。
スクリプトには以下の4種類があります。
(1)図面ファイルに保存するタイプ(VectorScriptコマンド)
(2)テキストファイルとして保存するタイプ(コマンドファイル)
(3)AppleScriptに埋め込むタイプ
(4)プラグイン(ツール、メニューコマンド、オブジェクト)

(1)手っ取り早いのはVectorScriptコマンドです。
図形選択マクロ、図形表示マクロ、ツールマクロはこのタイプになります。
新しいコマンドはリソースプラウザの「リソース」−「新規:<ファイル名>」−「VectorScript...」
で作ります。
パレット名とコマンド名を入力するとVectorScriptエディタが開くので、スクリプトをペーストします。
コンパイルボタン(上部右側のボタン)を押してエラーが出なければOKです。
スクリプトは他のコマンドと同様に、コマンドパレットから実行します。
VectorScriptコマンドは図面ファイルに保存するため、バージョン管理に難があります。

(2)コマンドファイルは、スクリプトをテキストファイルとして保存したものです。
実行は「階層」−「コマンドを実行...」か、「ファイル」−「取り込む」−「VectorScript...」です。
VW9.5までならリソースパレットからも実行できます。
コマンドをサーバに置けば厳密なバージョン管理が可能です。スクリプトの実行は少々煩雑です。

(3)AppleScriptについては、経験不足なので割愛します。

(4)スクリプトをプラグインにすると、スクリプトが手軽に実行でき、バージョン管理も簡単になります。
ただし、最初にプラグイン化してメニューやツールバーに登録する手間がかかります。

とりあえず(1)で作って、(2)でも保存しておき、使用頻度が高ければ(4)にするという感じです。


Re.2: 寸法値を位取りする   与太郎
email:  Mon Sep 5 20:36:25 2005

気に入ってもらえたようで嬉しいです。

PIOの中にはFInGroup(h)で入れるから寸法にも入れるのではと試したら、
FIn3D(h)で寸法の中身の図形ハンドルを取れました。


Re.: 寸法値を位取りする   石男
email:  Sat Sep 3 14:46:44 2005

>与太郎さん
なかなか良いものをありがとうございました。
位取りしても、そのまま寸法値が変更出来るのが良いですね。
標準で寸法値を位取りした後、訂正が面倒で辟易しておりました...。
この様なものを標準装備してもらいたいぐらいです。


寸法値を位取りする(4)   与太郎
email:  Wed Aug 31 18:34:33 2005

位取りを解除するスクリプトです。

procedure Reset_Kuraidori_Sel_ActLayer;
{ アクティブレイヤ上で選択した寸法の位取りを解除する(VW9以降に対応) }
{$ DEBUG}
const
_TextObj = 10;
_GroupObj = 11;
_DimObj = 63;
_SQ = Chr(39);{ ' }
_RecName = '寸法線-追加情報';
_Fld1 = '位取り';
var
_hL_:handle;
_sD, sL, sT, s0_:string;
_name, criteria_:string;

function Kuraidori(s:string):string;
{ 位取りした文字列を返す }
var
_i, ln_:integer;
_s0, s1, s2_:string;
begin
_ln:= Len(s);
_i:= Pos('.', s);
_if 0 < i then begin
__s1:= Copy(s, 1, i - 1);
__s2:= Copy(s, i, ln - i + 1);
_end
_else begin
__s1:= s;
__s2:= '';
_end;
_s0:= '';
_ln:= Len(s1);
_while (3 < ln) do begin
__s0:= Concat(Copy(s1, ln - 2, 3), s0);
__s1:= Copy(s1, 1, ln - 3);
__ln:= Len(s1);
__if ln <> 0 then
___s0:= Concat(',', s0);
_end;
_Kuraidori:= Concat(s1, s0, s2);
end;{Kuraidori}

procedure DoInContainer(hP:handle);
var
_h_:handle;
_s_:string;
_x1, y1, x2, y2_:real;
_x01, y01, x02, y02_:real;
begin
_case GetType(hP) of
__DimObj: h:= FIn3D(hP);
__GroupObj: h:= FInGroup(hP);
_end;
_while h <> nil do begin
__case GetType(h) of
___GroupObj: begin
____DoInContainer(h);
___end;
___TextObj: begin
____s:= Kuraidori(s0);
____s:= Concat(sL, s, sT);
____if GetText(h) = s then begin
_____GetBBox(h, x01, y01, x02, y02);
_____SetTextJust(h, 3);
_____GetBBox(h, x1, y1, x2, y2);
_____HMove(h, x01-x1, y01-y1);
_____SetText(h, sD);
____end;
___end;
__end;
__h:= NextObj(h);
_end;
end;{DoInContainer}

procedure DoDimension(hD:handle);
{ 寸法の位取りを解除する }
var
_h_:handle;
begin
_if GetType(hD) = DimObj then begin
__sD:= GetDimText(hD);
__sL:= GetObjectVariableString(hD, 9);
__sT:= GetObjectVariableString(hD, 10);
__sD:= Concat(sL, sD, sT);
__s0:= GetDimText(hD);
__DoInContainer(hD);
__SetRField(hD, RecName, Fld1, 'False');
__ReDraw;
_end;
end;{DoDimension}

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
___if i < lng then
____result:= Concat(Copy(result, 1, i), SQ, Copy(result, i+1, lng-i))
___else
____result:= Concat(Copy(result, 1, i), SQ);
___lng:= lng + 1;
___i:= i + 2;
__end{if}
__else begin
___i:= i + 1;
__end;{else}
_end;{while}
_AddSQ:= result;
end;{AddSQ}

begin{main}
_name:= Concat(SQ, AddSQ(GetLName(ActLayer)), SQ);
_criteria:= Concat('(L=',name, ')&(SEL=TRUE)');
_ForEachObject(DoDimension, criteria);
end;{main}
Run(Reset_Kuraidori_Sel_ActLayer);


寸法値を位取りする(3)   与太郎
email:  Tue Aug 30 17:32:19 2005

下の2つの書き込みのKuraidori関数は出鱈目でした。前から使ってるKuraidori関数と入れ替えときます。
勝手に解除される位取りを設定し直すのは面倒なので、1回設定したら解除されても後で一括して
位取り出来るようにします。
位取りの有無を保持するために寸法図形にレコードを割当てました。

procedure Kuraidori_Sel_ActLayer;
{ アクティブレイヤ上で選択した寸法の寸法値を位取りする(VW9以降に対応) }
{ 寸法を選択してなければ全ての寸法の位取りをやり直す }
{$ DEBUG}
const
_TextObj = 10;
_GroupObj = 11;
_DimObj = 63;
_SQ = Chr(39);{ ' }
_RecName = '寸法線-追加情報';
_Fld1 = '位取り';
var
_hL_:handle;
_sD, sL, sT, s0_:string;
_name, criteria_:string;

procedure AddRecord(h:handle);
{ 寸法線にレコードを割当てる }
begin
_if GetObject(RecName) = nil then
__NewField(RecName, Fld1, 'False', 2{boolean}, 0);
_Record(h, RecName);
_SetRField(h, RecName, Fld1, 'True');
end;{AddRecord}

function Kuraidori(s:string):string;
{ 位取りした文字列を返す }
var
_i, ln_:integer;
_s0, s1, s2_:string;
begin
_ln:= Len(s);
_i:= Pos('.', s);
_if 0 < i then begin
__s1:= Copy(s, 1, i - 1);
__s2:= Copy(s, i, ln - i + 1);
_end
_else begin
__s1:= s;
__s2:= '';
_end;
_s0:= '';
_ln:= Len(s1);
_while (3 < ln) do begin
__s0:= Concat(Copy(s1, ln - 2, 3), s0);
__s1:= Copy(s1, 1, ln - 3);
__ln:= Len(s1);
__if ln <> 0 then
___s0:= Concat(',', s0);
_end;
_Kuraidori:= Concat(s1, s0, s2);
end;{Kuraidori}

procedure DoInContainer(hP:handle);
var
_h_:handle;
_s_:string;
_x1, y1, x2, y2_:real;
_x01, y01, x02, y02_:real;
begin
_case GetType(hP) of
__DimObj: h:= FIn3D(hP);
__GroupObj: h:= FInGroup(hP);
_end;
_while h <> nil do begin
__case GetType(h) of
___GroupObj: begin
____DoInContainer(h);
___end;
___TextObj: begin
____if GetText(h) = sD then begin
_____s:= Kuraidori(s0);
_____s:= Concat(sL, s, sT);
_____GetBBox(h, x01, y01, x02, y02);
_____SetTextJust(h, 3);
_____GetBBox(h, x1, y1, x2, y2);
_____HMove(h, x01-x1, y01-y1);
_____SetText(h, s);
____end;
___end;
__end;
__h:= NextObj(h);
_end;
end;{DoInContainer}

procedure DoDimension(hD:handle);
{ 寸法の位取りをする }
var
_h_:handle;
begin
_if GetType(hD) = DimObj then begin
__sD:= GetDimText(hD);
__sL:= GetObjectVariableString(hD, 9);
__sT:= GetObjectVariableString(hD, 10);
__sD:= Concat(sL, sD, sT);
__s0:= GetDimText(hD);
__DoInContainer(hD);
__AddRecord(hD);
__ReDraw;
_end;
end;{DoDimension}

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
___if i < lng then
____result:= Concat(Copy(result, 1, i), SQ, Copy(result, i+1, lng-i))
___else
____result:= Concat(Copy(result, 1, i), SQ);
___lng:= lng + 1;
___i:= i + 2;
__end{if}
__else begin
___i:= i + 1;
__end;{else}
_end;{while}
_AddSQ:= result;
end;{AddSQ}

begin{main}
_name:= Concat(SQ, AddSQ(GetLName(ActLayer)), SQ);
_criteria:= Concat('(SEL=TRUE)&(T=DIMENSION)&(L=', name, ')');
_if Count(criteria) = 0 then
__criteria:= Concat(SQ, AddSQ(RecName), SQ, '.', SQ, AddSQ(Fld1), SQ, '=True')
_else
__criteria:= Concat('(L=',name, ')&(SEL=TRUE)');
_ForEachObject(DoDimension, criteria);
end;{main}
Run(Kuraidori_Sel_ActLayer);


寸法値を位取りする(2)   与太郎
email:  Fri Aug 26 17:49:14 2005

一応完成版です。
アクティブレイヤの寸法を選択して実行します。

procedure Kuraidori_Sel_ActLayer;
{ アクティブレイヤ上で選択した寸法の寸法値を位取りする(VW9以降に対応) }
{$ DEBUG}
const
_TextObj = 10;
_GroupObj = 11;
_DimObj = 63;
_SQ = Chr(39);{ ' }
var
_hL_:handle;
_sD, sL, sT, s0_:string;
_name, criteria_:string;

function Kuraidori(s:string):string;
{ 位取りした文字列を返す }
var
_i, iP_:integer;
_result_:string;
begin
_result:= '';
_iP:= Pos('.', s);
_if iP = 0 then iP:= Len(s) + 1;
_if iP <= Len(s) then begin
__result:= Copy(s, iP, Len(s)-iP+1);
__s:= Copy(s, 1, iP-1);
_end;
_while 3 < Len(s) do begin
__result:= Concat(',', Copy(s, Len(s)-3, 3), result);
__s:= Copy(s, 1, Len(s)-3);
_end;
_if s <> '' then result:= Concat(s, result);
_if Copy(result, 1, 1) = ',' then result:= Copy(result, 2, Len(result)-1);
_Kuraidori:= result;
end;{Kuraidori}

procedure DoInContainer(hP:handle);
var
_h_:handle;
_s_:string;
_x1, y1, x2, y2_:real;
_x01, y01, x02, y02_:real;
begin
_case GetType(hP) of
__DimObj: h:= FIn3D(hP);
__GroupObj: h:= FInGroup(hP);
_end;
_while h <> nil do begin
__case GetType(h) of
___GroupObj: begin
____DoInContainer(h);
___end;
___TextObj: begin
____if GetText(h) = sD then begin
_____GetBBox(h, x01, y01, x02, y02);
_____SetTextJust(h, 3);
_____GetBBox(h, x1, y1, x2, y2);
_____HMove(h, x01-x1, y01-y1);
_____s:= Kuraidori(s0);
_____s:= Concat(sL, s, sT);
_____SetText(h, s);
____end;
___end;
__end;
__h:= NextObj(h);
_end;
end;{DoInContainer}

procedure DoDimension(hD:handle);
{ 寸法の位取りをする }
var
_h_:handle;
begin
_if GetType(hD) = DimObj then begin
__sD:= GetDimText(hD);
__sL:= GetObjectVariableString(hD, 9);
__sT:= GetObjectVariableString(hD, 10);
__sD:= Concat(sL, sD, sT);
__s0:= GetDimText(hD);
__DoInContainer(hD);
__ReDraw;
_end;
end;{DoDimension}

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
___if i < lng then
____result:= Concat(Copy(result, 1, i), SQ, Copy(result, i+1, lng-i))
___else
____result:= Concat(Copy(result, 1, i), SQ);
___lng:= lng + 1;
___i:= i + 2;
__end{if}
__else begin
___i:= i + 1;
__end;{else}
_end;{while}
_AddSQ:= result;
end;{AddSQ}

begin{main}
_name:= Concat(SQ, AddSQ(GetLName(ActLayer)), SQ);
_criteria:= Concat('(L=',name, ')&(SEL=TRUE)');
_ForEachObject(DoDimension, criteria);
end;{main}
Run(Kuraidori_Sel_ActLayer);

ボックステキストにすると文字がはみ出るので、あらかじめ前記号に空白をいれて調整してください。


寸法値を位取りする   与太郎
email:  Thu Aug 25 13:38:44 2005

標準の位取りツールを使うと寸法を直しても寸法値が更新されないので、
他に方法がないか考えてみました。

procedure test;
{ 寸法値を位取りする(VW9以降に対応) }
{$ DEBUG}
const
TextObj = 10;
GroupObj = 11;
DimObj = 63;
var
hD, h:handle;
sD, sL, sT:string;

function Kuraidori(s:string):string;
var
i, iP:integer;
result:string;
begin
result:= '';
iP:= Pos('.', s);
if iP = 0 then iP:= Len(s) + 1;
if iP <= Len(s) then begin
result:= Copy(s, iP, Len(s)-iP+1);
s:= Copy(s, 1, iP-1);
end;
while 3 < Len(s) do begin
result:= Concat(',', Copy(s, Len(s)-3, 3), result);
s:= Copy(s, 1, Len(s)-3);
end;
if s <> '' then result:= Concat(s, result);
if Copy(result, 1, 1) = ',' then result:= Copy(result, 2, Len(result)-1);
Kuraidori:= result;
end;{Kuraidori}

procedure DoInContainer(h:handle);
var
s:string;
begin
while h <> nil do begin
case GetType(h) of
GroupObj: begin
h:= FInGroup(h);
DoInContainer(h);
end;
TextObj: begin
if GetText(h) = sD then begin
s:= Kuraidori(GetDimText(hD));
s:= Concat(sL, s, sT);
SetText(h, s);
end;
end;
end;
h:= NextObj(h);
end;
end;{DoInContainer}

begin
hD:= FSActLayer;
if GetType(hD) = DimObj then begin
sD:= GetDimText(hD);
sL:= GetObjectVariableString(hD, 9);
sT:= GetObjectVariableString(hD, 10);
sD:= Concat(sL, sD, sT);
h:= FIn3D(hD);
DoInContainer(h);
ReDraw;
end;
end;
Run(test);

寸法線の中に入って、無理やり寸法値を書き換えています。
ですから寸法線に変更を加えると位取りは無効になります。


何故かフリーハンドツール   与太郎
email:  Thu Jun 9 18:44:59 2005

気分転換にフリーハンドツールを書いてみました。
環境設定で「クリック-ドラッグ描画」にしてない場合は、標準のフリーハンドツールとほと
んど同じですが、「クリック-ドラッグ描画」の場合にマウスボタンを放しても終了しません。
終了するにはもう一度クリックします。

標準ツールは多角形の頂点を随時追加しているため、描画中に多角形全体がちらつきますが、
こちらは一旦直線を生成して最後に多角形を作っているので、画面はちらつきません。

procedure FreeHand;
{$ DEBUG}
var
_h, hG_:handle;
_aPixcel_:real;
_x1, y1, x2, y2_:real;
_start, stop_:boolean;
_showAll_:boolean;
_
begin
_DSelectAll;
_showAll:= GetPref(14);
_SetPref(14, true);
_start:= false;
_stop:= false;
_Message('マウスボタンを押して、曲線を描いてください。');
_SetCursor(SmCrossC);
_BeginGroup;
_repeat
__if start then begin
___GetMouse(x2, y2);
___if not EqualPt(x1, y1, x2, y2) then begin
____LineTo(x2, y2);
____h:= LNewObj;
____SetDSelect(h);
____if hBtm = nil then
_____hBtm:= h;
____ReDraw;
____x1:= x2; y1:= y2;
___end;
___if MouseDown(x2, y2) then begin
____stop:= true;
___end;
__end
__else if MouseDown(x1, y1) then begin
___Message('もう一度マウスボタンを押すと終了します。');
___start:= true;
___MoveTo(x1, y1);
__end;
_until stop;
_EndGroup;
_hG:= LNewObj;
_SetPref(14, showAll);
_ClrMessage;
_if hG <> nil then begin
__h:= FInGroup(hG);
__if h <> nil then begin
___OpenPoly;
___BeginPoly;
___GetSegPt1(h, x1, y1);
___AddPoint(x1, y1);
___repeat
____GetSegPt2(h, x2, y2);
____AddPoint(x2, y2);
____h:= NextObj(h);
___until h = nil;
___EndPoly;
___SetFPat(LNewObj, 0);
___DelObject(hG);
__end;
_end;
_ReDrawAll;
end;
Run(FreeHand);

気が付いたこと。
1. マウスを押しっぱなしにしてもGetMouseが2回目からはTrueを返さなかったので、マウ
スボタンを押して描き始め、ボタンを離して終了、という具合には出来ませんでした。
標準ツールでは出来ているので、何か方法はあるはずですが...。
2. 最初はBeginPolyとEndPolyの中で直線を一本ずつ消してましたが、上手くいきませんで
した。それで直線をグループ内で生成して、多角形生成後に削除するように修正しました。
3. BeginGroupとEndGroupの間で直線を生成すれば、グループ図形を一個削除すれば済むの
で、そのように修正したら描画中に背後の図形が消えてしまいました。これは環境設定の
「グループ編集時に他の図形を表示」をTrueにすれば直りました。
1〜3の原因がなかなか判らず、最初15分位で作れると思っていたのに何時間もかかってしま
いました。
また、実行中に画面のパンとズームが出来ません(出来てもほとんど無意味ですが)。

それから、今出来た図形にスムージングを掛けたら、頂点が減ったんでビックリしました。
これってVW11からでしたっけ?
単純に頂点を間引いてるだけなので、元の図形と全然重なってませんけど...


全ての文字を「上揃え」にする。   与太郎
email:  Mon May 23 22:34:29 2005

古いVWでのDXF/DWG書き出しで、一部の文字が半文字〜1文字分下にズレていることがあり
ました。変換プログラムが、文字基点が「上」であるのを前提に変換しているのが原因のよ
うなので、全ての文字を「上揃え」にすれば位置ズレはは起きません。(フォントの違いに
よるズレは別のはなしです。)

procedure ResetTextVertical;
{ 全ての文字を「上揃え」にする。 }
const
_stepMessage = 50;
var
_h_:handle;
_i, c, n, iD_:longint;

procedure DoText(h:handle);
const
_TextVertical_Top = 1;
var
_y0, x1, y1, x2, y2_:real;
begin
_if GetTextVerticalAlign(h) <> TextVertical_Top then begin
__GetBBox(h, x1, y0, x2, y2);
__SetTextVerticalAlign(h, TextVertical_Top);
__GetBBox(h, x1, y1, x2, y2);
__HMove(h, 0, y0-y1);
__c:= c + 1;
_end;
_i:= i + 1;
_if i >= iD then begin
__Message('文字を「上揃え」にする:', c, '/', i, '/', n);
__iD:= iD + stepMessage;
_end;
end;{DoText}

begin{main}
_c:= 0; i:= 0; iD:= stepMessage;
_n:= Count(T=TEXT);
_ForEachObject(DoText, T=TEXT);
_Message(n, '個中、', c, '個の文字を「上揃え」にしました。');
end;
Run(ResetTextVertical);

Vectorcriptの「警告」メッセージが出ますけど、無視して構いません。


全ての文字の行間隔を「行間全角」にする   与太郎
email:  Sun May 22 21:31:37 2005

JWCに変換するとき、行間隔が大きい文字のサイズが大きくなってしまいました。
他のCADのデータを読み込んだら勝手に行間隔が大きくなっていたようです。
私自身はラップ・テキストは使わないので、行間隔を変更する必要はありません。
ですから、ラップ・テキスト以外の文字の行間隔を全て「行間全角」に戻すスク
リプトを書いてみました。

procedure ResetTextSpace;
{ ラップ・テキスト以外の文字の行間隔をリセットする。 }
var
_h_:handle;
_i, c, n_:longint;

procedure DoText(h:handle);
const
_SingleSpace = 2;
begin
_if GetTextSpace(h) <> SingleSpace then begin
__if not GetTextWrap(h) then begin
___SetTextSpace(h, SingleSpace);
___c:= c + 1;
__end;
_end;
_i:= i + 1;
_Message('行間隔をリセット:', c, '/', i, '/', n);
end;{DoText}

begin{main}
_c:= 0; i:= 1;
_n:= Count(T=TEXT);
_ForEachObject(DoText, T=TEXT);
_Message(n, '個中、', c, '個の文字の行間隔をリセットしました。');
end;
Run(ResetTextSpace);

文字が多いとき(数千〜)は、Messageを間引けば相当早くなると思います。


Re.^2:曲線の円弧半径を得るには   石男
email:  Wed May 18 17:38:33 2005

>曲線を作る時に実際の半径を計算するのは面倒なので...
わたしの場合、曲線作る時は円弧と直線を交差させて「抜き取り」という要領が多いの
で。これで作ると「フィレットの設定」で再度設定しないと駄目なんです。
ただ、この再設定のデフォルト値が実際の半径に確かになっているのが、何か微妙な感
じがしますね。
>NNAかA&Aに関数1個作ってもらえば解決ですね...
はい、その通りです...。


Re.:曲線の円弧半径を得るには   与太郎
email:  Wed May 18 17:30:21 2005

実際のフィレット半径を得る関数(GetVertRadius)を書いてみました。

5/16の書き込みのDoMenuTextByName のパラメータは、'Decompose' の間違いでした。
'Convert to Lines' だと全て直線に分解されてしまいます。
マニュアルには'Decompose Curve'とありますが、'Decompose'が正しいようです。

分解された図形は頂点番号と逆順に生成されているので、円弧の順番は、頂点を逆順に辿っ
て調べています。

複製図形も分解された図形も、元の曲線図形の階層の一番上に出来ます。
それで、複製した図形(hD)の下の図形のハンドル(hTop)をPrevObj(hD)で取っておくと、
分解された最初の図形のハンドル(h)はNextObj(hD);で得られます。
こうすると、曲線図形がどの階層にあってもGetVertRadiusは正常に動作します。

GetArcRadiu関数の中でDSelectAllを実行しているので、選択図形のハンドルを取って処理
するスクリプトだと、最初に全ての選択図形のハンドルを保存する必要があります。

PIOでは無理だと書きましたが、実際に試してはないので定かではありません。
PIOの中でDoMenuTextByNameを使えるのでしょうか?

procedure test;
{ クリックした曲線のフィレット半径を調べる }
const
_Filet = 3;
_ArcObj = 6;
_CurveObj = 21;
var
_err_:boolean;
_h_:handle;
_i, iA, n, tp_:integer;
_x0, y0, x, y, r, d, d0_:real;

function GetArcRadius(h:handle):real;
{ 円弧図形の半径を返す。 }
var
_x1, y1, x2, y2_:real;
begin
_Get2DPt(h, 1, x1, y1);
_Get2DPt(h, 2, x2, y2);
_GetArcRadius:= Distance(x1, y1, x2, y2);
end;{GetArcRadius}

function GetVertType(h:handle; i:integer):integer;
{ 曲線の頂点のタイプを返す。 }
var
_result_:integer;
_x, y, r_:real;
begin
_GetPolylineVertex(h, i, x, y, result, r);
_GetVertType:= result;
end;{GetVertType}
_
function GetVertRadius(hC:handle; i:integer; var err:boolean):real;
{ 曲線hのi番目の頂点のフィレット半径(実径)を返す。 }
var
_result_:real;
_h, hC2, hA, hD, hTop_:handle;
_iV, iA_:integer;
begin
_if (GetType(hC) <> CurveObj) | (GetVertType(hC, i) <> Filet) then begin
__err:= true;
__result:= 0;
_end
_else begin
__err:= false;
__{ 最後から何番目の円弧か調べる }
__iA:= 0;
__for iV:= GetVertNum(hC) downto i do begin
___if GetVertType(hC, iV) = Filet then begin
____iA:= iA + 1;
___end;
__end;
__{ 曲線を分解 }
__hC2:= HDuplicate(hC, 0, 0);
__hTop:= PrevObj(hC2);
__DSelectAll;
__SetSelect(hC2);
__DoMenuTextByName('Decompose', 0);
__{ 円弧のハンドルを得る }
__hA:= nil;
__iV:= 1;
__h:= NextObj(hTop);
__while (h <> nil) do begin
___hD:= h;
___if GetType(h) = ArcObj then begin
____if iV = iA then
_____hA:= h;
____iV:= iV + 1;
___end;{if}
___h:=NextObj(h);
___DelObject(hD);
__end;{while}
__result:= GetArcRadius(hA);
_end;
_GetVertRadius:= result;
end;{GetVertRadius}

begin{test}
_DSelectAll;
_ReDraw;
_Message('曲線をクリックしてください。');
_GetPt(x, y);
_h:= PickObject(x, y);
_if (h <> nil) & (GetType(h) = CurveObj) then begin
__SetTool(-214);
__SetSelect(h);
__ReDraw;
__n:= GetVertNum(h);
__Message('半径を調べる頂点をクリックしてください。');
__GetPt(x0, y0);
__iA:= 0;
__d0:= HPerim(h);
__for i:= 1 to n do begin
___GetPolylineVertex(h, i, x, y, tp, r);
___d:= Distance(x0, y0, x, y);
___if d < d0 then begin
____iA:= i;
____d0:= d;
___end;
__end;
__if GetVertType(h, iA) = Filet then begin
___Message('R(', iA, ') = ', GetVertRadius(h, iA, err));
__end
__else begin
___AlrtDialog('半径を調べる頂点をクリックしてください。');
___ClrMessage;
__end;
_end
_else begin
__AlrtDialog('曲線をクリックしてください。');
__ClrMessage;
_end;
end;
Run(test);


Re.:曲線の円弧半径を得るには   与太郎
email:  Mon May 16 21:25:49 2005

石男さんへ、
>曲線図形のデータパレットのフィレット設定を再度設定すると
>きちんと円弧半径が取得できます。
「フィレットの設定」を開くと半径のデフォルト値が実際の半径になってるので、「OK」
ボタンを押したらその値に再設定される理屈です。
曲線を作る時に実際の半径を計算するのは面倒なので、最大直径を指定する(またはゼロ
を指定する)ほうが合理的ですが、頂点の情報を調べる時には実際の半径のほうが知りた
いですね。

>仕様なのでしょうがないかな。
データパレットには表示されるし、実際の半径が判らないと図形が生成できないので、VW
の内部では値を持ってる筈です。NNAかA&Aに関数1個作ってもらえば解決ですね...

PIOだと無理ですが、普通のスクリプトなら、

hC:= HDuplicate(hCurve, dx, dy);
DSelectAll;
SetSelect(hC);
DoMenuTextByName('Convert to Lines', 0);
で曲線を分解して、

n:= GetVertexNum(hCurve);
c:= 0;
for i:= 1 to 求める頂点番号 do begin
_GetPolylineVertex(hCurve, i, x, y, tp, r);
_if tp = 円弧頂点 then
__c:= c + 1;
end;{for}
で何番目の円弧か調べて、

h:= FSActLayer; { もしかしたら LSActLayer かも }
hArc:= nil;
i:= 1;
while (h <> nil) & (i <= c) do begin
_if GetType(h) = 円弧図形 then begin
__if i = c then
___hArc:= h;
__i:= i + 1;
_end;{if}
_h:= NextSObj(h); { LSActLayer なら PredSObj(h); }
end;{while}
のような方法で円弧図形のハンドル(hArc)を取って、実際の半径を求められます。
グループや3D図形の中でも実行可能にしようとすると面倒になりますが...

VW11の裏の関数に、
ConvertToPolygon(h: HANDLE; resolution: INTEGER) : HANDLE;
というのがあるので、もしPIOの中で使えたら、3個の頂点を調べて半径を求めることも
不可能ではないと思います。


Re.:曲線の円弧半径を得るには   石男
email:  Mon May 16 18:07:16 2005

与太郎さんへ
>GetPolylineVertex(h, i, x, y, tp, R);で返ってくるRは設定値...
という曲線図形の円弧半径が取れない...ってお話がありましたが、曲線図形のデータ
パレットのフィレット設定を再度設定するときちんと円弧半径が取得できます。

これはどうやら曲線図形を作る際に、円弧を設定せず曲線をつくると上の現象が起きる
ようですが、普通曲線図形を作るのに円弧を指定しながら作る方が難しいと思うのです
が...、仕様なのでしょうがないかな。


Re:クリック図形と異なるタイプの図形を選択解除するスクリプト   与太郎
email:  Mon May 16 8:43:47 2005

訂正です。

{ 異なる種類の図形を選択解除します。 }begin の、beginの前の改行が消えています。
__ForEachObj(DoObject, SEL=TRUE); は、
__ForEachObject(DoObject, SEL=TRUE); の間違いです。

元のスクリプトはFInGroup, FInSymbol, FInLayerでハンドルを取って、whileループで全
部の図形にアクセスしてました。書き込む直前に、ForEachObject1行で済むことに気付い
て書き直しましたが、確認せずに書き込んでしまいました。


クリック図形と異なるタイプの図形を選択解除するスクリプト   与太郎
email:  Sat May 14 12:35:03 2005

数種類のPIOを選択したとき、データパレットの挙動がMac版とWin版(デモ版)で異なります。
VW10,11/Mac → クラスとレイヤ以外表示されません。不便ではあるものの、問題はありません。
VW10,11/Win → 最初に選択されたPIO、または名前のコード番号が小さいPIOのパラメータが表
示され、変更もできます。ただし、データパレットに表示されていないPIOの、同じ位置のパラ
メータも変更されてしまいます。パラメータはPIOごとに異なるので、想定外の動作やエラーが
起きます。

PIOのパラメータが変な値で書き換えられると困るので、選択図形から目的外の種類の図形を選
択解除するスクリプトを書いてみました。
メニュー化して、コンテキストメニューに登録すると便利だと思います。
文字や寸法だけ選択したい場合も、選択マクロより早いです。

procedure DSelectOtherTypeObject;
{ クリック図形と異なるタイプの図形を選択解除します。 }
{ 種類が異なるPIO、シンボル選択解除します。 }
const
_SymbolObj = 15;
_PlugInObj = 86;
var
_h_:handle;
_tp_:integer;
_symName,
_recName_:string;
_x, y_:real;

procedure DoObject(h:handle);
{ 異なる種類の図形を選択解除します。 }begin
_if GetType(h) = tp then begin
__case tp of
___SymbolObj: begin
____if symName <> GetSymName(h) then begin
_____SetDSelect(h);
____end;
___end;
___PlugInObj: begin
____if recName <> GetName(GetRecord(h, 1)) then begin
_____SetDSelect(h);
____end;
___end;
__end;
_end
_else begin
__SetDSelect(h);
_end;
end;{DoObject}

begin{main}
_Message('選択したままにするタイプの図形をクリックしてください。');
_repeat
__GetPt(x, y);
__h:= PickObject(x, y);
_until (h = nil) | Selected(h);
_ClrMessage;
_if h = nil then begin
__AlrtDialog('選択したままにするタイプの図形をクリックしてください。');
_end
_else begin
__tp:= GetType(h);
__case tp of
___SymbolObj: begin
____symName:=GetSymName(h);
___end;
___PlugInObj: begin
____recName:= GetName(GetRecord(h, 1));
___end;
__end;
__ForEachObj(DoObject, SEL=TRUE);
_end;
end;
Run(DSelectOtherTypeObject);


連続してポリゴンを作成するスクリプト   与太郎
email:  Wed Apr 27 12:54:46 2005

連続して3D多角形(三角形)を描くスクリプトです。
3D基準点をクリックして、3D多角形を作成します。
三斜を切るスクリプトにも応用できるはずです。

procedure Draw3DPolys;
{ 連続3D三角形作成 }
label
_999;
const
_Locus3DObj = 9;
_Poly3DObj = 25;
var
_result_:boolean;
_h, hL_:handle;
_xC, yC, x0, y0, x1, y1, x2, y2, x3, y3_:real;
_x, y, z_:array[0..3] of real;
_i, n_:integer;
_
procedure GetNext3DPoint(x0, y0:real; var x1, y1:real; var result:boolean);
var
_h_:handle;
_hP_:handle;
_i, j_:integer;
_x4, y4_:real;
_x2, y2_:array[0..3] of real;
_x3, y3, z3_:array[0..3] of real;
begin
_result:= false;
_repeat
__GetPtL(x0, y0, x1, y1);
__h:= PickObject(x1, y1);
__if (h <> nil) then begin
___if (GetType(h) = Locus3DObj) then begin
____GetLocus3D(h, x[3], y[3], z[3]);
____x[3]:= x[3] - xC; y[3]:= y[3] - yC;
____if ((x[1] <> x[3]) | (y[1] <> y[3]) | (z[1] <> z[3])) &
___ _ ((x[2] <> x[3]) | (y[2] <> y[3]) | (z[2] <> z[3])) then begin
_____result:= true;
____end;
___end
___else if (GetType(h) = Poly3DObj) then begin
____Tab(4);
____for i:= 1 to 3 do begin
_____GetPolyPt3D(h, i-1, x3[i], y3[i], z3[i]);
_____x3[i]:= x3[i] - xC; y3[i]:= y3[i] - yC;
_____Locus3D(x3[i], y3[i], z3[i]);
_____hP:= LNewObj;
_____GetBBox(hP, x2[i], y2[i], x4, y4);
_____x2[i]:= (x2[i]+x4)/2; y2[i]:= (y2[i]+y4)/2;
_____DelObject(hP);
____end;
____x2[0]:= x2[1]; y2[0]:= y2[1];
____j:= 1;
____for i:= 2 to 3 do begin
_____if Distance(x1, y1, x2[i], y2[i]) < Distance(x1, y1, x2[0], y2[0]) then begin
______x2[0]:= x2[i]; y2[0]:= y2[i];
______j:= i;
_____end;
____end;
____x[3]:= x3[j]; y[3]:= y3[j]; z[3]:= z3[j];
____x1:= x2[j]; y1:= y2[j];
____result:= true;
___end
___else begin
____SysBeep;
____Message('3D基準点をクリックしてください。');
___end;
__end;
_until result | (h = nil);
end;{GetNext3DPoint}
_
begin{main}
_GetOrigin(xC, yC);
_ClosePoly;
_Message('最初の3D基準点をクリックしてください。');
_GetPt(x1, y1);
_h:= PickObject(x1, y1);
_if (h = nil) | (gETtYPE(H) <> Locus3DObj) then begin
__AlrtDialog('3D基準点をクリックしてください。');
__Goto 999;
_end;
_GetLocus3D(h, x[1], y[1], z[1]);
_x[1]:= x[1] - xC; y[1]:= y[1] - yC;
_Message('2番目の3D基準点をクリックしてください。');
_GetPtL(x1, y1, x2, y2);
_h:= PickObject(x2, y2);
_if (h = nil) | (gETtYPE(H) <> Locus3DObj) then begin
__AlrtDialog('3D基準点をクリックしてください。');
__Goto 999;
_end;
_GetLocus3D(h, x[2], y[2], z[2]);
_x[2]:= x[2] - xC; y[2]:= y[2] - yC;
_if EqualPt(x[1], y[1], x[2], y[2]) then begin
__Goto 999;
_end;
_MoveTo(x1, y1);
_LineTo(x2, y2);
_hL:= LNewObj;
_ReDraw;
_Message('3番目の3D基準点をクリックしてください。');
_GetNext3DPoint(x2, y2, x3, y3, result);
_DelObject(hL);
_if not result then begin
__AlrtDialog('3D基準点をクリックしてください。');
__Goto 999;
_end;
_if EqualPt(x[1], y[1], x[3], y[3]) | EqualPt(x[2], y[2], x[3], y[3]) then begin
__Goto 999;
_end;
_Poly3D(x[1], y[1], z[1], x[2], y[2], z[2], x[3], y[3], z[3]);
_HMoveBackward(LNewObj, true);
_ReDraw;
_repeat
__x0:= x3; y0:= y3;
__x[0]:= x[3]; y[0]:= y[3]; z[0]:= z[3];
__Message('次のポリゴンの頂点にする3D基準点をクリックしてください。空クリックで終了。');
__GetNext3DPoint(x0, y0, x3, y3, result);
__if result then begin
___if Distance(x1, y1, x3, y3) < Distance(x2, y2, x3, y3) then begin
____x[2]:= x[0]; y[2]:= y[0]; z[2]:= z[0];
____x2:= x0; y2:= y0;
___end
___else begin
____x[1]:= x[0]; y[1]:= y[0]; z[1]:= z[0];
____x1:= x0; y1:= y0;
___end;
___if EqualPt(x[1], y[1], x[3], y[3]) | EqualPt(x[2], y[2], x[3], y[3]) then begin
____result:= false;
___end
___else begin
____Poly3D(x[1], y[1], z[1], x[2], y[2], z[2], x[3], y[3], z[3]);
____HMoveBackward(LNewObj, true);
____ReDraw;
___end;
__end;
_until not result;
999:
_ClrMessage;
end;
Run(Draw3DPolys);


Re2:直線上の点   石男
email:  Sat Apr 23 14:02:27 2005

>素人さんは手を出しちゃいけねえよ(笑)。
確かに(笑)きっと、ある場所も分からないかも...。拡張子pのファイルよりhファイ
ルの方が確かです。ただ、Cで書かれてありますが。

自分で作るかとも思ったのですが、あるものは使おうという方針なので...。


Re:直線上の点   与太郎
email:  Fri Apr 22 22:06:41 2005

>裏の手続き/関数
素人さんは手を出しちゃいけねえよ(笑)。
どのバージョンでも使えるわけでなく、同バージョンでも使えるとは限らないですからねぇ。
プラグイン開発者が自分のプラグインで使うために作ってるんですから、まちがった使い方
をしてトラブっても文句を言ってゆくわけにもいかないし。
でも、手続き/関数の定義部(宣言部?)を見ただけで使い方が一目瞭然なのが多いので、
ついつい誘惑に負けてしまうと...

自分で関数を作るなら、点と線の座標を、線が水平になるように回転して、Y座標の差を比べます。
X座標を調べれば、実際に線上にあるか、延長線上にあるかも判ります。直線の公式(y=ax+b)
で求めるのと違って、条件分けを考える必要がありません。
実際に図形を書いて回転すれば、座標変換も不要です。


RE:CreateListBoxN    案山子
email:  Thu Apr 21 18:29:42 2005

>このItemIDに何が定義されているか
>全て確認することは出来ますか?

VectorScript Language Guide
http://www.nemetschek.net/support/custom/vscript/docs.html

Online Function Reference
http://www.nemetschek.net/support/custom/vscript/functionref/VSFunctionReference.html


直線上の点   石男
email:  Wed Apr 20 15:50:47 2005

直線と直線の交点を調べる手続き/関数はあっても、直線上の点なのか調べる手続き/
関数はないんですね。裏の手続き/関数にこんなものがありました。
PtOnLine(ptX, ptY, ptZ: REAL; begPtX, begPtY, begPtZ: REAL; endPtX, endPtY,
endPtZ: REAL; tolerance: REAL) : BOOLEAN;
tolerance以外のReal型引数はVector型です。正確には
PtOnLine(pt, begpt, endpt : VECTOR; tolerance: REAL) : BOOLEAN;
toleranceは許容値でした。これをシビアにするとオンザラインになりません。
カスタマイズもほどほどと思う今日この頃...。


RE:CreateListBoxN ameri
email:  Tue Apr 19 18:39:38 2005

>SetupDialogC は VectorScript の内部で定義されているItem ID というふうに考えて
ください。
このItemIDに何が定義されているか
全て確認することは出来ますか?


RE:CreateListBoxN  案山子
email:  Mon Apr 18 15:27:56 2005

>SetupDialogCは一見ラベルのようですけれどもこれも特殊だが決まり文句だと思えばいいのですか?

SetupDialogC は VectorScript の内部で定義されているItem ID というふうに考えて
ください。


RE:CreateListBoxN ameri
email:  Sat Apr 16 21:30:56 2005

返答ありがとうございます。
dataは気にしないで良いけれどは使われているのですね?
SetupDialogCは一見ラベルのようですけれどもこれも特殊だが決まり文句だと思えばいいのですか?
このようなラベルは他にもあるのですか?


Re.CreateListBoxN  石男
email:  Sat Apr 16 11:07:41 2005

> AandAのサンプルCreateListBoxNについて
では変数itemが意味しているのは「OK」=1、「Cancel」=2、「CreateListBoxN」=4になります。3は使っていません。変数dataは特に気にせずに。

>SetupdDialogCは何を意味するのか?
Drive_ListDialogScriptが呼ばれた時、言い換えればカスタムダイアログを呼び出した際、最初のダイアログ表示はどのアイテムをどのように表示するかという意味に理
解した方が分かりやすいです。
ですから、このサンプルではアイテム「CreateListBoxN」の中身をSetupdDialogCで
定義しています。




CreateListBoxN ameri
email:  Fri Apr 15 16:56:58 2005

A&AのサンプルCreateListBoxNについて
PROCEDURE Drive_ListDialogScript( VAR item:LONGINT; data:LONGINT );
この手続きのitem,dataがどう扱われるのか?
CASE item OF SetupDialogC: BEGIN
このcase文は一般的なcase文は違うようですがSetupdDialogCは何を意味するのか?
教えてください。


Re:プラグインのスクリプトを修正する    springsnow
email:
simoga2@ceres.ocn.ne.jp  Wed Apr 13 10:40:14 2005

早速の返答ありがとうございました。
使用することができました。
また何かありましたら よろしくお願いします。


プラグインのスクリプトを修正する   与太郎
email:  Mon Apr 11 13:21:50 2005

typeという変数名を使っているVW8用のPIO(Plug-in Object)は、VW9以降ではエラーが出て使え
ません。使えるようにするにはPIOのScriptを修正する必要があります。
VectorScriptエディタでは文字の検索/置換が出来ないので、一旦テキストエディタにコピー
してから修正します。

type ⇒ wyeTypeに変更する例:
1. 修正する前に、念の為プラグインの複製を作っておきます。
2. 「階層」―「プライングコマンド...」でプラグインを選択して、「コマンド編集...」ボタン
でVectorScriptエディタを開きます。
3. テキスト(Script)を全選択後コピーして、テキストエディタにペーストします。
4. 「wyeType」を単語検索してScriptで使われてないことを確認します。
5. 全ての「type」という単語を「wyeType」に置換えます。エディタで単語単位の検索が可能な
ら「全置換」で構いません。そうでなければ検索された「type」が単語か単語の一部か確認しな
がら、単語なら「置換えして次に」、単語の一部なら「次を検索」で最後まで進みます。
6. 修正したScriptをVectorScriptエディタにコピーします。
7. コンパイル・ボタン(VectorScriptエディタの左上)を押してエラーが出なければOKです。


Re:寸法線のフォントと文字サイズをまとめて変更する  manabu
email:  Sun Apr 10 10:17:01 2005

自己レス
大変御丁寧なご返答ありがとうございます。
早速、自分でも練ってみたいと思います。


Re:寸法線のフォントと文字サイズをまとめて変更する   与太郎
email:  Fri Apr 8 23:45:06 2005

manabuさん、はじめまして。

寸法のフォントやサイズ設定専用のprocedureはありません。SetObjectVariable???という汎用
のprocedureで設定します。
SetObjectVariable???(図形ハンドル, セレクタ番号, 設定値); という要領です。

VectorScript 11.0 Function Reference ⇒ Additional Resources ⇒ VectorScript Appendix
⇒ Appendix G - Object Selectors ⇒ Dimensions に寸法図形のセレクタ番号が載っています。
VW11では、フォントIDのセレクタ番号が28、文字サイズのセレクタ番号が40になっています。
フォントIDはinteger型、文字サイズはreal型なので、
フォントIDは SetObjectVariableInt(objectHandle, 28, fontID);
文字サイズは SetObjectVariableReal(objectHandle, 40, textSize);
で設定出来ます。
たとえば、下のようになります。(_はタブに変換、または削除して実行してください。)

procedure SetDimTextAttr;
{ 選択されている寸法のフォントと文字サイズを設定する。 }
const
_FontName = 'MS ゴシック';
_TextSize = 12;
var
_c_:longint;

procedure DoDimension(h:handle);
{ ForEachObjectから呼ばれるサブルーチン }
begin
_c:= c + 1;
_SetObjectVariableInt(h, 28, GetFontID(FontName));
_SetObjectVariableReal(h, 40, TextSize);
_ResetObject(h);
end;{DoDimension}

begin{main}
_c:= 0;
_ForEachObject(DoDimension, ((T=DIMENSION) & (SEL=TRUE)));
_ReDrawAll;
_if c = 0 then begin
__AlrtDialog('寸法が選択されていません!');
_end
_else begin
__AlrtDialog(Concat(c, '個の寸法のフォントと文字サイズを設定しました。'));
_end;
end;{main}
Run(SetDimTextAttr);

SetObjectVariable???で設定しても、ResetObjectを実行しないと図形の表示は変わりません。

※ 今までConcat(Num2Str(0, c), 'XXX')と書いてましたが、Concat(c, 'XXX')でも問題ないよ
うです。


寸法線のフォントと文字サイズをまとめて変更する  manabu
email:  Fri Apr 8 21:55:18 2005

VectorWorks談話室の方から移動してきました
VW11 Plusに含まれる文字セットメニューの様なもので寸法線のフォントと文字サイズをまとめて変更するコマンドが作りたいのですが
SetTextFontやSetTextSizeといった関数はありますが
寸法線Dimensionsにはこのような関数はないようです
どうすればよいでしょうか


アクティブレイヤの文字を選択する   与太郎
email:  Fri Apr 8 19:30:57 2005

検索条件に「アクティブレイヤ」がないので、アクティブレイヤの名前で指定しますが、
SelectObj((L=ActLayer)&(T=Text)); も、 SelectObj((L=GetLName(ActLayer))&(T=Text));
もうまくゆきません。一旦変数にレイヤ名を入れて、変数で指定する必要があります。

procedure SelectActLayerText;
{ アクティブレイヤの文字を選択する }
var
layerName:string;
begin
layerName:= GetLName(ActLayer);
DSelectAll;
SelectObj((L=layerName)&(T=Text));
end;
Run(SelectActLayerText);

このスクリプトでは、本当にアクティブレイヤの文字しか選択されません。
編集可能なレイヤの文字を全て選択するには、
1. 全ての図形を選択解除。
2. Control(Command)+Aで編集可能な図形を全て選択。
3. 文字以外を選択解除する。
でいいはずです。スクリプトにすると、

{ 編集可能なレイヤの文字を選択する }
DSelectALL;
DoMenuTextByName('Select All', 0);
DSelectObj(T<>Text);

となります。


フォント番号を調べてたら...   与太郎
email:  Fri Apr 8 12:59:46 2005

フォントIDとフォント名のリストを Output.txt/Output File に書き出すスクリプトです。

procedure GetFontList;
var
_i_:longint;
_ft_:array[-32768..32767] of boolean;
_fn_:string;
begin
_Message('配列を初期化中...');
_for i:= -32768 to 32767 do
__ft[i]:= false;
_Message('フォントを調査中...');
_for i:= -32768 to 32767 do begin
__fn:= GetFontName(i);
__if fn <> '' then
___ft[GetFontID(fn)]:= true;
_end;
_Message('書き出し中...');
_for i:= -32768 to 32767 do begin
__if ft[i] | (i = 0) | (i=1) then begin
___Write(i);
___Tab(1);
___WriteLn(GetFontName(i));
__end;
_end;
_SysBeep;
_Message('終わりました!');
end;
Run(GetFontList);

iをlongint型にしているのは、integer型だとforループが無限ループになるからです。
理由は、forループの最後でi(32767)に1を加算しますが、integerの範囲を超えるため、
32768ではなく-32768になってしまうからです。これは、forループの始めで i>32767 か
どうかでループの終了を判定しているからでしょう。forループの終わりで i=32767 を
終了条件としていればinteger型でも問題なかったはずですが、いまさら変更されても困
りますけど(forループの後でカウンタ変数を参照している場合もありますし)。

あと、Win2000のフォントIDでひとつ気付いたことがあります。
それは、ID=0 のフォントが「@HGP創英角ゴシックUB」だったことです。
Win版のVWで時々みかける、文字が横向きに表示されちゃうという現象は、プログラム内
でフォントIDを入れ忘れて、IDがゼロになって縦書き用フォントになるのが原因ではない
かと想像出来ます。


Re. 回転順序   石男
email:  Thu Apr 7 11:22:30 2005

自己レスです。どうやら、z軸ーx軸の回転順序で大丈夫みたいですね。
トトロさんとこの大学のwebにそんな記述をみつけました。偉大な担当教員がいました
ね。出来れば、任意軸廻り回転のみのサブルーチン化して欲しいです...。


回転順序   石男
email:  Thu Apr 7 8:10:01 2005

頭の中がぐるぐる回っています...、バックナンバーにSet3DRotについてのトトロさん
の記述がありました。回転角度はデグリーで指定していますが、思ったようにxyz軸に
対して回転してくれません。一通りやってみたのですが、どの回転順序が正しいのか
わかりません。だれか分かる方いませんか?


WSをグループ図形に変換するスクリプト(バグ修正3)   与太郎
email:  Wed Apr 6 17:46:09 2005

縦罫線の不具合を修正しました。
リソースプラウザでVectorScriptコマンドを新規作成して、下のスクリプトをペーストしてください。
コピペする前に「_」(全角下線)をタブに変換、または削除してください。

デスクトップにテキストファイルとして保存し、「階層」―「コマンドを実行...」でも実行できます。

使い方は、図形化したいワークシートを表示、またはワークシート図形を選択して、実行します。
一度に一個のWSが変換されます。
ワークシート図形を選択した場合は同じ位置に図形が出来ます。アクティブなワークシートを変換す
るときは、コマンド実行後、図形を作る位置(左上)をクリックしてください。
図形の種類別にクラスを分けているので、線の太さや色はクラス属性で変えられます。

procedure WS_to_GroupObj;
{ Version 0.999 }
{ ワークシートをグループ図形にします(var9以降に対応)}
{ by 与太郎 2004/04/03〜2004/04/03 }
{ 2004/04/12 ワークシート図形を選択しても実行するように修正}
{ 〃 ワークシート図形を選択したときは同位置にグループ図形を作成、ワークシート図形を削除する }
{ 〃 列幅がゼロのときは文字を表示しないように修正 }
{ 〃 グリッドの色をシアンに変更 }
{ 2004/8/26 データベースのサブ行も表示するように修正 }
{ 〃 非表示グリッドのクラスを定義 }
{ 2005/4/6 縦罫線のバグ修正 }
{ 図形化したいワークシートを表示、またはワークシート図形を選択して、実行する }
{ 属性はクラス属性で変更可能 }
{ クラス名、クラス属性、セルの余白は好みで書き換えてください。 }
{$ DEBUG}
const

{ クラス名とクラス属性 }
_ClsWSText = 'WS-Text';
_ClsWSGrid = 'WS-Grid';
_ClsWSGridHd = 'WS-Grid_Hide';{ ----2004/8/26 追加 }
_ClsWSOutLine = 'WS-Outline';
_ClsWSBorder = 'WS-Border';
_OutlineWidth = 21;{ 0.53ミリ }
_OutlineColor = 15;{ 赤色 }
_GridWidth = 1;{ 0.025ミリ }
_GridColor = 2;{ シアン }
_GridHdWidth = 1;{ 0.025ミリ }{ ----2004/8/26 追加 }
_GridHdColor = 5;{ 黄色 }{ ----2004/8/26 追加 }
_LnWidth = 11;{ 0.28ミリ }
_LnColor = 4;{ 青色 }
_txtColor = 15;{ 赤色 }
_
{ セルの余白 }
_LeftMargin = 3;{ 3ポイント=1.06ミリ }
_RightMargin = 3;{ 3ポイント=1.06ミリ }

{ オブジェクト識別番号 }
_ShowGrid = 83;{ WSのグリッド表示 }{ ----2004/8/26 追加 }
_
type
_wsCell = structure
__subAlign, { ----2004/8/26 追加 }
__align_:integer;{ 0=標準/1=左よせ/2=センタ/3=右よせ }
__txt_:string;{ セルの内容 }
__fontID_:integer;
__size_:integer;
__Style_:integer;{Plain:0/Bold:1/Italic:2/Underline:4/Outline:8/Shadow:16}
_end;{structure}
_
var
_k_:real;_{ 描画倍率 }
_hWS_:handle;_{ WSのハンドル }
_hTbl_:handle;_{ WS図形のハンドル }
_maxRow, maxClm_:integer;_{ WSの行数,列数 }
_maxRowDB_:integer;_{ サブ行を含んだ行数 }{ ----2004/8/24 追加 }
_indexRDB_:dynArray[] of integer;_{ 行番号→サブ行を含んだ行番号 }{ ----2004/8/24 追加 }
_wd_:dynArray[] of integer;_{ セル幅 }
_ht_:dynArray[] of integer;_{ セル高さ }
_subRows_:dynArray[] of integer;_{ サブ行の数 }{ ----2004/8/24 追加 }
_x_:dynArray[] of real;_{ セル境界のX座標 }
_y_:dynArray[] of real;_{ セル境界のY座標 }
_hLine_:dynArray[,] of boolean;_{ 横罫線の有無 }
_vLine_:dynArray[,] of boolean;_{ 縦罫線の有無 }

procedure Set_k;{ 描画倍率を計算します。 }
var
_scale_:real;
_upi_:real;
_fraction, display_:longint;
_format_:integer;
_name, squareName_:string;
begin
_scale:= GetLScale(ActLayer);
_GetUnits(fraction, display, format, upi, name, squareName);
_k:= upi * scale / 25.4 / 72 * 25.4;
end;{Set_k}

procedure GetWSHandle(var hWS, hTbl:handle);
{ ワークシートとワークシート図形のハンドルを返します。 }
begin
_hWS:= ActSSheet;
_if hWS = nil then begin
__hTbl:= FSActLayer;
__if (hTbl <> nil) & (GetType(hTbl) = 56) then begin
___hWS:= GetWSFromImage(hTbl);
__end;{if}
_end;{if}
end;{GetWSHandle}

function Row2RowDB(row, subRow:integer):integer;
begin
_Row2RowDB:= indexRDB[row] + subRow;
end;{Row2RowDB}

procedure Init_Vars;{ 変数を初期化します。 }
var
_row, rowDB, clm_:integer;{ ----2004/8/24 rowDBを追加 }
_top, left, bottom, right_:boolean;
_
_procedure Set_or(var source:boolean; dist:boolean);
_begin
__source:= source or dist;
_end;{Set_or}
_
_begin{Init_Vars}
__{ 配列を確保 }
__GetWSRowColumnCount(hWS, maxRow, maxClm);
__Allocate indexRDB[0..maxRow];{ ----2004/8/24 追加 }
__Allocate subRows[0..maxRow];{ ----2004/8/24 追加 }
__
_{ ↓2004/8/24 追加 }
__for row:= 1 to maxRow do
___subRows[row]:= 0;
__indexRDB[0]:= 0;
__subRows[0]:= 0;
__for row:= 1 to maxRow do begin
___if IsWSDatabaseRow(hWS, row) then
____GetWSSubrowCount(hWS, row, subRows[row]);
___indexRDB[row]:= indexRDB[row-1] + subRows[row-1] + 1;
__end;{for}
__maxRowDB:= indexRDB[maxRow] + subRows[maxRow];
_{ ↑2004/8/24 追加 }
__
__Allocate ht[1..maxRowDB];
__Allocate wd[1..maxClm];
__Allocate x[0..maxClm];
__Allocate y[0..maxRowDB];
__Allocate hLine[0..maxRowDB, 0..maxClm];
__Allocate vLine[0..maxRowDB, 0..maxClm];
__
__{ セルの寸法を取得 }
__for row:= 1 to maxRow do
___GetWSRowHeight(hWS, row, ht[row]);
__for clm:= 1 to maxClm do
___GetWSColumnWidth(hWS, clm, wd[clm]);
__
__{ 罫線を取得 }
__for row:= 0 to maxRow do begin
___for clm:= 0 to maxClm do begin
____hLine[row, clm]:= false;
____vLine[row, clm]:= false;
___end;{for}
__end;{for}
__
_{ ↓2004/8/26 修正 }
__for row:= 1 to maxRow do begin
___for rowDB:= indexRDB[row]+0 to indexRDB[row]+SubRows[row] do begin
____for clm:= 1 to maxClm do begin
_____GetWSCellBorder(hWS, row, clm, top, left, bottom, right);
_____Set_or(hLine[rowDB-1, clm], top);
_____Set_or(hLine[rowDB, clm], bottom);
_____Set_or(vLine[rowDB, clm-1], left);
_____Set_or(vLine[rowDB, clm], right);
____end;{for}
___end;{for}
__end;{for}
_{ ↑2004/8/24 修正 }
end;{Init_Vars}

procedure Set_XY;{ XY座標を計算します。 }
var
_row, rowDB, clm_:integer;{ ----2004/8/24 rowDBを追加 }
begin
_for clm:= 1 to maxClm do
_x[clm]:= x[clm-1] + k * wd[clm];

{ ↓2004/8/24 修正 }
_for row:= 1 to maxRow do
__for rowDB:= indexRDB[row]+0 to indexRDB[row]+SubRows[row] do
___y[rowDB]:= y[rowDB-1] - k * ht[row];
{ ↑2004/8/24 修正 }
end;{Set_XY}

function BeClass(cls:string):boolean;
{ クラスの有無を返します。 }
var
_i_:integer;
_be_:boolean;
begin
_i:= 1;
_be:= false;
_while (i <= ClassNum) & (not be) do begin
__if cls = ClassList(i) then
__be:= true;
__i:= i + 1;
_end;{while}
_BeClass:= be;
end;{BeClass}

procedure SetClassAttrs;{ ----2004/8/26 修正 }
{ クラス属性を設定します。クラスがある場合は何もしません。 }
_
_procedure SetClsAttr(cls:string; col, wd:integer);
_begin
__if not BeClass(cls) then begin
___NameClass(cls);
___SetClPenFore(cls, col);
___SetClLW(cls, wd);
__end;{if}
_end;{SetClsAttr}
_
begin{SetClassAttrs}
_SetClsAttr(ClsWSGrid, GridColor, GridWidth);
_SetClsAttr(ClsWSGridHd, GridHdColor, GridHdWidth);
_SetClsAttr(ClsWSOutline, OutlineColor, OutlineWidth);
_SetClsAttr(ClsWSBorder, lnColor, lnWidth);
_SetClsAttr(ClsWSText, txtColor, 14);
end;{SetClassAttrs}

procedure DrawGrid;{ ----2004/8/24 修正 }
{ グリッドを描きます。 }
var
_rowDB, clm_:integer;
begin
_BeginGroup;
__for rowDB:= 1 to maxRowDB-1 do begin
___MoveTo(x[0], y[rowDB]);
___LineTo(x[maxClm], y[rowDB]);
__end;{for}
__
__for clm:= 1 to maxClm-1 do begin
___MoveTo(x[clm], y[0]);
___LineTo(x[clm], y[maxRowDB]);
__end;{for}
_EndGroup;
end;{DrawGrid}

procedure DrawOutline;{ ----2004/8/24 修正 }
{ 外枠を描きます。 }
begin
_Rect(x[0], y[0], x[maxClm], y[maxRowDB]);
end;{DrawOutline}

procedure DrawHBorders;{ ----2004/8/24 修正 }
{ 水平線を書きます。 }
var
_rowDB, c1, c2_:integer;
_
_function StartClm(c:integer):integer;
_begin
__repeat
___c:= c + 1;
__until (maxClm <= c) | (hLine[rowDB, c]);
__if (c <= maxClm) & (hLine[rowDB, c]) then
___StartClm:= c
__else
___StartClm:= 0;
_end;{StartClm}
_
_function EndClm(c:integer):integer;
_begin
__while (c < maxClm) & hLine[rowDB, c+1] do
___c:= c + 1;
__EndClm:= c;
_end;{EndClm}
_
begin{DrawHBorders}
_for rowDB:= 0 to maxRowDB do begin
__c1:= StartClm(0);
__while (c1 <> 0) do begin
___c2:= EndClm(c1);
___MoveTo(x[c1-1], y[rowDB]);
___LineTo(x[c2], y[rowDB]);
___c1:= StartClm(c2);
__end{while}
_end;{for}
end;{DrawHBorders}

procedure DrawVBorders;{ ----2004/8/24 修正 }
{ 垂直線を描きます。 }
var
_clm, r1, r2_:integer;
_
_function StartRow(r:integer):integer;
_begin
__repeat
___r:= r + 1;
__until (maxRowDB <= r) | (vLine[r, clm]);
__if (r <= maxRowDB) & (vLine[r, clm]) then
___StartRow:= r
__else
___StartRow:= 0;
_end;{StartRow}
_
_function EndRow(r:integer):integer;
_begin
__while (r < maxRowDB) & vLine[r+1, clm] do
___r:= r + 1;
__EndRow:= r;
_end;{EndRow}

begin{DrawVBorders}
_for clm:= 0 to maxClm do begin
__r1:= StartRow(0);
__while (r1 <> 0) do begin
___r2:= EndRow(r1);_{ ----2005/4/6 修正(行の入れ替え) }
___MoveTo(x[clm], y[r1-1]);{ ----2005/4/6 修正(行の入れ替え) }
___LineTo(x[clm], y[r2]);_{ ----2005/4/6 修正(行の入れ替え) }
___r1:= StartRow(r2);
__end{while}
_end;{for}
end;{DrawVBorders}

function CellAlign(h:handle; row, clm, subRow:integer):integer;{ ----2004/8/26 追加 }
{ セルの文字揃えを返します。 }
var
_result_:integer;
begin
_GetWSCellAlignment(h, row, clm, result);
_if result = 0 then begin
__if subRow = 0 then begin
___if CellHasNum(h, row, clm) then
____result:= 3
___else
____result:= 1;
__end{if}
__else begin
___if IsWSSubrowCellNumber(h, row, clm, subRow) then
____result:= 3
___else
____result:= 1;
__end;{else}
_end;{if}
_CellAlign:= result;
end;{CellAlign}

procedure DrawTexts;{ ----2004/8/26 修正 }
{ セルの文字を描きます。 }
var
_row, rowDB, subRow, clm_:integer;
_cell_:wsCell;
_xT, yT_:real;
begin
_TextVerticalAlign(5);{ 下揃え }
_for row:= 1 to maxRow do begin
__for clm:= 1 to maxClm do begin
___if (0 < wd[clm]) then begin
____for subRow:= 0 to subRows[row] do begin
_____if subRow = 0 then
______GetWSCellString(hWS, row, clm, cell.txt)
_____else
______GetWSSubrowCellString(hWS, row, clm, subRow, cell.txt);
_____if (cell.txt <> '') then begin
______GetWSCellTextFormat(hWS, row, clm, cell.fontID, cell.size, cell.style);
______cell.align:= CellAlign(hWS, row, clm, subRow);
______case cell.align of
_______0, 1: xT:= x[clm-1] + k * LeftMargin;
_______2: xT:= (x[clm-1] + x[clm]) / 2;
_______3: xT:= x[clm] - k * RightMargin;
______end;{case}
______rowDB:= row2rowDB(row, subRow);
______yT:= y[rowDB];
______TextJust(cell.align);
______TextFont(cell.fontID);
______TextSize(cell.size);
______TextOrigin(xT, yT);
______CreateText(cell.txt);
______SetTextStyle(LNewObj, 0, GetTextLength(LNewObj), cell.style);
_____end;{if}
____end;{for}
___end;{if}
__end;{for}
_end{for}
end;{DrawTexts}

begin{main}
_GetWSHandle(hWS, hTbl);
_if hWS = nil then begin
__AlrtDialog('ワークシートを開くか、選択してください。');
_end{if}
_else begin{ グループ図形を描く }
__PushAttrs;
__DSelectAll;
__Set_k;
__Init_Vars;
__if hTbl = nil then begin
___Message('図形を描く位置(左上)をクリックしてください。');
___GetPt(x[0], y[0]);
__end{if}
__else begin
___GetBBox(hTbl, x[0], y[0], x[maxClm], y[maxRow]);
__end;{else}
__Set_XY;
__SetClassAttrs;
__BeginGroup;
___FillPat(0);
___LSByClass;
___LWByClass;
___PenColorByClass;
___NameClass(ClsWSText);
___DrawTexts;
___if GetObjectVariableBoolean(hWS, ShowGrid) then{ ----2004/8/26 追加 }
____NameClass(ClsWSGrid)
___else
____NameClass(ClsWSGridHd);
___DrawGrid;
___NameClass(ClsWSBorder);
___BeginGroup;
____DrawHBorders;
____DrawVBorders;
___EndGroup;
___NameClass(ClsWSOutline);
___DrawOutline;
__EndGroup;
__if hTbl <> nil then
___DelObject(hTbl)
__else
___ClrMessage;
__PopAttrs;
__ReDrawAll;
_end;{else}
end;{main}
Run(WS_to_GroupObj);


訂正:面図形をスライス(3)   与太郎
email:  Fri Mar 11 23:06:32 2005

>VW11でも900〜1000は0〜500の倍の時間がかかってますが、
「VW11でも900〜1000は0〜100の倍の時間がかかってますが、」の間違いです。

いちおう図形のスライスは出来たので、3Dに変換して曲線に沿って曲げてみたいと
思いますが、2週間ほど手を付けられません。
そういうわけで、ご希望の方にスクリプトを完成させる権利を差し上げます。
とりあえず期限は3/31まで。


Re3:面図形をスライス(3)   与太郎
email:  Thu Mar 10 22:37:52 2005

Winで時間を計ろうとしたら、VW9とVW10では切欠きが出来ませんでした。
MoveTo(x, y1);
LineTo(x, y2);
を、
MoveTo(x, yL);
LineTo(x, yU);
に直す必要があります。

私のショボイPC(Cel/1.1GHz/Win2000)で四角形を700分割するのに要した時間です。
(全部デモ版でやってます。)
取消し   ON  OFF(0回)
VW9    ―― 38.5
VW10   20.5 15.9
VW11   16.3 13.6

う〜ん、思った以上に時間がかかってます。やはりセレロンのせいでしょうか?
Appleの主張を裏付ける結果になってしまいました。


RE2:面図形をスライス(3)   与太郎
email:  Thu Mar 10 8:31:38 2005

masafumiさん、おはようございます。
>記憶が定かで有りませんが、環境設定の取消回数の数も比例していたような気がします。
回数は関係ないですが、取消回数をゼロにしたら700分割がそれぞれ13.9秒(VW8.5)、
9.6秒(VW9.5)、13.9秒(VW11)になりました。


RE:面図形をスライス(3)  masafumi
email:  Thu Mar 10 1:42:23 2005

こんばんは、与太郎さん。

>あと、VW8.5と9.5だと、最初は早くても後半は急激に遅くなるという、納得しがたい
>結果になりました。これは画面の書き換えが関係してるようです。

記憶が定かで有りませんが、環境設定の取消回数の数も比例していたような気がします。


面図形をスライス(3)   与太郎
email:  Wed Mar 9 22:26:33 2005

procedure Slice2をいろんなバージョンで実行してみたら、予想外の結果でした。
まず、VW8.5(Classic環境)の場合、分割数が1,000でVWのメモリ割当が48MBだとメ
モリ不足でエラーになってしまいました。MaxNumの値は3か4で十分だと思います。
凸形状なら1でも構いません。
あと、VW8.5と9.5だと、最初は早くても後半は急激に遅くなるという、納得しがたい
結果になりました。これは画面の書き換えが関係してるようです。VW11ではReDrawし
ない限り、実行中の画面の書き換えは起こりません。

以下はPowerBookG3/400MHz OS10.3.7上で四角形をスライスした結果です。
実行する度に1割くらい変わることもあるので、何回か実行して、最短時間を計りま
した。1分以上は計測していません。
分割数  100  200  300  400  500  600  700  800  900 1000
VW8.5   1.0  2.6  6.5 12.9 23.0 39.6 62.6 ―― ―― ――
VW9.5   1.2  2.8  6.1 12.3 21.7 36.0 55.7 ―― ―― ――
VW11   1.7  3.8  5.9  8.2 10.7 13.4 16.2 19.5 22.5 25.9

VW11でも900〜1000は0〜500の倍の時間がかかってますが、このくらいの増加率なら
分割数に比例と言い切ってもいいでしょうか?
VW10.5では試していませんが、(たぶん)VW11と同じような傾向になると思います。


面図形をスライス(2)   与太郎
email:  Tue Mar 8 22:27:12 2005

100分割以上ならこちらのほうが高速です。スクリプトも短くて簡単になりました。

procedure Slice2;
{ 図形を縦にスライスします。 }
label
_999;
var
_x1, y1, x2, y2_:real;
_x, dx, yL, yU_:real;
_numSlice, c_:integer;
_h_:handle;

procedure CutObject(h0:handle; x:real);
const
_MaxNum = 16;
var
_hP_:array[1..MaxNum] of handle;
_h, hC_:handle;
_xc, yc_:real;
_i, n_:integer;
begin
_c:= c + 1;
_Message('分割中...', c, '/', numSlice);
_MoveTo(x, y1);
_LineTo(x, y2);
_hC:= LNewObj;
_DSelectAll;
_SetSelect(h0);
_SetSelect(hC);
_DoMenuTextByName('Clip Surface', 0);
_DelObject(hC);
_h:= FSActLayer;
_n:= 0;
_while (h <> nil) & (n < MaxNum)do begin
__n:= n + 1;
__hP[n]:= h;
__h:= NextSObj(h);
_end;
_if MaxNum < n then begin
__SysBeep;
__AlrtDialog('図形が複雑すぎて,完全には分割できません。');
_end;
_for i:= 1 to n do begin
__HCenter(hP[i], xc, yc);
__if x < xc then begin
___CutObject(hP[i], x+dx);
__end;
_end;
end;{CutObject}

begin{main}
_h:= FSActLayer;
_if h = nil then begin
__AlrtDialog('図形を選択してください。');
__Goto 999;
_end;
_numSlice:= IntDialog('分割数 = ', '25');
_if DidCancel then
__Goto 999;
_GetBBox(h, x1, y1, x2, y2);
_dx:= (x2 - x1) / numSlice;
_x:= x1 + dx;
_yU:= y1 + dx;
_yL:= y2 - dx;
_c:= 0;
_CutObject(h, x);
_Message('終わりました!!(', numSlice, '分割)');
999:
end;{main}
Run(Slice2);


面図形をスライス   与太郎
email:  Mon Mar 7 12:58:50 2005

下のような多角形(面属性なし)を作って「切り欠き」コマンドで図形をスライスしています。
┌┐┌┐┌┐
││││││
││││││
│└┘└┘│
そのため、分割数を増やすと実行時間が激増します。(「切り欠き」コマンドの仕様です。)
直線で(N-1)回切断するようにすれば、実行時間が分割数に比例するように出来ます。

procedure Slice;
{ 図形を縦にスライスします。 }
label
_999;
const
_MaxNum = 99;
_LF = Chr(13);
var
_x1, y1, x2, y2_:real;
_x, y, dx, lastY_:real;
_numSlice, i_:integer;
_h, h0, h1, h2, h3_:handle;
begin
_h1:= FSActLayer;
_if h1 = nil then begin
___AlrtDialog('図形を選択してください。');
___Goto 999;
_end;
_h0:= PrevObj(h1);
_h2:= NextObj(h1);
_numSlice:= IntDialog('分割数 = ', '25');
_if DidCancel then
__Goto 999;
_if MaxNum < numSlice then begin
__if not YNDialog(Concat(Num2Str(0, numSlice), '分割って、マジっすか?', LF, '(時間が

かかります)')) then
___Goto 999;
_end;
_if ((MaxNum * 3) div 2) < numSlice then begin
___AlrtDialog(Concat('一度に分割すると時間がかかり過ぎます。', LF, '何回かに分けて、分割

してください。'));
___Goto 999;
_end;
_GetBBox(h1, x1, y1, x2, y2);
_dx:= (x2 - x1) / numSlice;
_x:= x1 + dx;
_y1:= y1 + dx;
_y2:= y2 - dx;
_y:= y1;
_lastY:= y;
_OpenPoly;
_BeginPoly;
_while x < x2 do begin
__AddPoint(x, y);
__if y = lastY then begin
___if y = y1 then
____y:= y2
___else
____y:= y1;
__end
__else begin
___lastY:= y;
___x:= x + dx;
__end;
_end;
_EndPoly;
_h3:= LNewObj;
_SetFPat(h3, 0);
_DSelectAll;
_SetSelect(h1);
_SetSelect(h3);
_Message('分割中...');
_DoMenuTextByName('Clip Surface', 0);
_DelObject(h3);
_h:= h0;
_if h = nil then
__h:= FActLayer
_else
__h:= NextObj(h0);
_i:= 0;
_repeat
__i:= i + 1;
__SetSelect(h);
__h:= NextObj(h);
_until h = h2;
_Message('N = ', i);
999:
end;
Run(Slice);


Re.4:図形の数   石男
email:  Sat Mar 5 16:25:07 2005

h3 := IntersectSurface(h1, h2);とDoMenuTextByName('Intersect Surface', 0);を
使った場合、抜き取った図形が出来る位置(前後)が違いました。という訳で以下のサ
ブルーチンを...。h2がカッター図形となります。
{******* 抜き取り********}
Function Nukitori( h1 , h2 : Handle ) : Integer ;
Var
j : Integer ;
NewHand , h3 , h : Handle ;

Begin
h := NextObj( h2 ) ;
h3 := IntersectSurface( h1, h2 ) ;
ReDrawAll ;
NewHand := NextObj( h2 ) ;
While NewHand <> h Do
Begin
j := j + 1;
SetSelect( NewHand ) ;
SetLW( NewHand , 21) ;
ReDrawAll ;
NewHand := NextObj( NewHand ) ;
End ;
Nukitori := j ;
End ;


Re:図形の数   与太郎
email:  Fri Mar 4 18:09:48 2005

もう一個思い付きました。こちらのほうが簡単です。
抜き取り後、SetDSelectで元の図形を選択解除すれば、抜き取った図形だけが選択状
態になってるはず。


Re.2:図形の数   石男
email:  Fri Mar 4 16:03:00 2005

h3 := IntersectSurface(h1, h2);こちらで抜き取りを行っていたもので、思いつきま
せんでした。なるほど参考になりました。
>(文字コードのせい?)
どうも文字コードの問題のようです、OS XではOSの操作によってUnicodeだったり、そ
うでなかったりするみたいです。半角英数なら問題ないみたいです。


Re2:図形の数   与太郎
email:  Fri Mar 4 15:48:59 2005

抜き取った図形が一番上に出来るのではないみたいです。
カッター図形とその上の図形の間に、抜き取った図形が出来るので、
「抜き取り前にLSActLayerでハンドルh1を, NextObj(h1)でh2を取っておいて、
抜き取った後でNextObj(h1)をh1がh2になるまで続けます。」
が正解のようです。

procedure test;
var
_i_:integer;
_h1, h2_:handle;
begin
i:= 0;
h1:= LSActLayer;
h2:= NextObj(h1);
DoMenuTextByName('Intersect Surface', 0);{ 図形の抜き取り }
h1:= NextObj(h1);
while h <> h2 do begin
_i:= i + 1;
_SetLW(h1, 21);{ 線を太くします }
_h1:= NextObj(h1);
end;{while}
Message('N=', i);
end;
Run(test);


Re:図形の数   与太郎
email:  Fri Mar 4 13:12:46 2005

>やはり、図形の作成前と後での比較しかないでしょうか?
数を知りたいだけなら、それが一番早いと思います。

抜き取った図形のハンドルを取るには、抜き取り前にLActLayerでハンドルhを取って
おいて、抜き取った後でNextObj(h)をhがnilになるまで続けます。そのついでに数も
数えられます。

procedure test;
var
_i_:integer;
_h_:handle;
begin
i:= 0;
h:= LActLayer;
DoMenuTextByName('Intersect Surface', 0);{ 図形の抜き取り }
h:= NextObj(h);
while h <> nil do begin
_i:= i + 1;
_SetLW(h, 21);{ 線を太くします }
_h:= NextObj(h);
end;{while}
Message('N=', i);
end;
Run(test);


Re.:図形の数   石男
email:  Fri Mar 4 13:08:28 2005

自己レスです、やはり作成の前後で図形の数を比較するしかなそうです。
>与太郎さん
OS Xのファイルパスでの日本語使用の問題は10.3あたりから直ったはずです。ちょっと
記憶が定かではありませんが...。


Dir(ファイル一覧)コマンド   与太郎
email:  Fri Mar 4 11:55:26 2005

VW11のVWPluginLibraryRoutines.pの中に色々使えそうな関数があったので、ファイル
一覧を表示するスクリプトを書いてみました...が、
悲しいかなOSXでは日本語の文字化けのため、まともに動きません。VWが固まってしま
います。(文字コードのせい?)
何千個もファイルがあるフォルダを選択した場合は、終わるまでに数分かかります。
早くするにはMessage表示を間引く必要があります。

procedure Dir;
{ フォルダー内のファイル一覧を「Output.txt」書き出します。 }
const
Sep = '\';
var
i, c:integer;
dirPath:string;
t, t0:longint;
major, minor, maintenance, platform :integer;

procedure SubDir(path:string; tb:integer);
var
j:integer;
s, s0:string;
begin
tb:= tb + 1;
j:= 0;
repeat
j:= j + 1;
s0:= GetFilesInFolder(path, j);
if (s0 <> '') & (s0 <> '.') & (s0 <>'..') then begin
c:= c + 1;
s:= Concat(path, Sep, s0);
Tab(tb); WriteLn(s0);
Message(c, ': ', s);
SubDir(s, tb);
end;
until s0 = '';
end;{SubDir}

begin
t0:= GetTickCount;
GetVersion(major, minor, maintenance, platform);
if platform = 1 then begin
AlrtDialog('Macでは正常に動作しません。');
end
else begin
c:= 0;
i:= GetFolder('フォルダーを選択してください。', dirPath);
if copy(dirPath, Len(dirPath), 1) = Sep then
dirPath:= Copy(dirPath, 1, Len(dirPath)-1);
WriteLn(dirPath);
SubDir(dirPath, 0);
t:= GetTickCount;
Message('Finished!! (', (t-t0)/60, 'sec.)'); SysBeep;
end;
end;
Run(Dir);


図形の数   石男
email:  Fri Mar 4 11:16:04 2005

図形の数を数えるには、Count、NumObj等色々やり方があると思いますが、スクリプト
で新しく作成した図形の数を把握するにはどうしたら良いでしょうか?カウンタを付け
てという手も考えましたが、抜き取りで図形を作成するため、何個図形が出来るのかが
分かりません。やはり、図形の作成前と後での比較しかないでしょうか?


Re.: XYでソート   石男
email:  Tue Mar 1 18:25:32 2005

>与太郎さん
早速ありがとうございました。昔、与太郎さんとmasafumiさんのやりとりの中でソー
トがあったので、お勉強していましたがさっぱりわかりませんでした。ソートや再帰
は苦手です。
>ループから呼ばれるのにAllocateしてますし...
全然問題ありません、メモリーの食う呪文は私の得意のするところです。これで、一
気に進みます。特殊業務のせいか、わたしの作るものはみなさんのお役にたてないも
のばかりです。


XYでソート   与太郎
email:  Tue Mar 1 17:53:28 2005

こんな感じで出来ます。
procedure SortXは全く最適化してません。
ループから呼ばれるのにAllocateしてますし...
でも、千個くらいなら数秒で終わります。

procedure SetNumber;
{ 選択した基準点に番号を打つ }
{$ DEBUG}
type
_locusInfo = structure
__x, y_:real;
__h_:handle;
_end;
var
_loc_:dynArray[] of locusInfo;
_i, st, ed_:integer;
_num_:longint;
_lastY_:real;
_name_:string;

procedure GetLocus(h:handle);
begin
_i:= i + 1;
_GetLocPt(h, loc[i].x, loc[i].y);
_loc[i].h:= h;
end;{GetLocus}

procedure SortX(iSt, iEd:integer);
{ Xでソート }
var
_i_:integer;
_temp_:dynArray[] of locusInfo;
begin
_Allocate temp[iSt..iEd];
_for i:= iSt to iEd do
__temp[i]:= loc[i];
_SortArray(temp, iEd, 1);
_for i:= iSt to iEd do
__loc[i]:= temp[i];
end;{SortX}

begin{main}
_name:= GetLName(ActLayer);
_num:= Count((L=name)&(T=LOCUS)&(SEL=TRUE));
_if (num < 1) | (32767 < num) then begin
__AlrtDialog('32767個以下の基準点を選択してください。');
_end
_else begin
__Allocate loc[1..num];
__i:= 0;
__ForEachObject(GetLocus, (L=name)&(T=LOCUS)&(SEL=TRUE));
__if i <> num then begin
___AlrtDialog('何故かiとnumが一致しません。');
__end
__else begin
___SortArray(loc, num, 2);_{ Yでソート }
___
___{ Xでソート }
___st:= 1;
___i:= 1;
___lastY:= loc[1].y;
___while i <= num do begin
____if loc[i].y = lastY then begin
_____ed:= i;
____end
____else begin
_____if st < ed then
______SortX(st, ed);
_____st:= i;
_____ed:= i;
_____lastY:= loc[i].y
____end;
____i:= i + 1;
___end;
___if st < ed then
____SortX(st, ed);
___
___{ 番号を打つ }
___for i:= 1 to num do begin
____TextOrigin(loc[i].x, loc[i].y);
____CreateText(Num2Str(0, i));
___end;
__end;
_end;
end;{main}
Run(SetNumber);


SortArray(loc, num, 1); { Xでソート }
SortArray(loc, num, 2); { Yでソート }
で上手くいくかと思いましたが、やっぱりダメでした。
SortArrayすると、同じ値内で順番が前後します。


ソート?   石男
email:  Tue Mar 1 15:01:18 2005

         *B 例えば左の様にバラバラに配置された座標点で点Aから点Bにか
* ** *  *  * けて番号を振っていきたいのです。条件としてはy座標の昇順、
  *        x座標の昇順という感じだと思うのですが...。
 *     *   イメージとしては座標を配列に入れてソートしていくのでしょう
  *   *   *が...。
 *A


Re3:配列サイズについて   石男
email:  Thu Feb 24 17:13:27 2005

確かにですね、取りあえず配列作ってなんでも入れちゃえと思っている私の場合、配列
を整理する配列が欲しくなったりしますから...。もっとも最近は構造体の配列使って
ドツボというパターンもあります。ただ、テキストを扱うとやっぱりIntegerでは足ら
ないと思います。


Re2:配列サイズについて   与太郎
email:  Wed Feb 23 20:31:16 2005

>小細工が必要
ちょうど今、小細工が必要になりそうなスクリプトを書いてるんですが、
とりあえずは普通の配列でやってみて,完成してから小細工を施そうと思ってます。今のまま
だと配列の制限で1万個強のデータしか処理できないのです。
おそらく処理時間がデータ数の1.5乗に比例して増えると思うので,配列を大きくし過ぎるのも
考え物ですが、データを分けたり結果をまとめたりの手間を考えたら,どちらが得とも言い切
れないですね。処理中はほっとけばいいので、大きくするに越したことはないですが。

>時代は大容量
ですが、容量に処理速度が追いついて行かないのが現実ですね。(うちだけ?)
データのバックアップの時間もなかなか取れません。昔は昼休憩の間に出来たのに。


Re.:配列サイズについて   石男
email:  Wed Feb 23 17:48:19 2005

> 配列範囲が-32768〜32767までというのは少なすぎます。
はい、確かに少ないです。
NumObj( h:HANDLE ) :LONGINT ; なんかで配列を決めようとしても、小細工が必要に
なってきますからね。時代は大容量なんですから何とかして欲しいですね。


配列サイズについて   与太郎
email:  Wed Feb 23 16:59:59 2005

配列範囲が-32768〜32767までというのは少なすぎます。
いまどき、ちょっとした図面でも図形数が3万個を超えてしまいます。かといって,配列の下
限をマイナス値にするとスクリプトが判りにくくなってしまいます。
また、付随する変数の配列が、図形数の何倍も必要なこともあります。
そろそろ配列の範囲をINTEGER(16bit)からLONGINT(32bit)に変えてもいいというか、必要
だと思いません?

メモリ量から見ると、LONGINT型変数の配列範囲を0〜2,147,483,647にした場合でも8MBです。
現実にはそこまで大きな必要ないので、たとえば10万個のBoundBoxの座標(x1,y1,x2,y2)の
配列を作ると場合、100,000 x 4 x 8 = 3,200,000ですから、必要なメモリは3MB程度です。
10年前ならともかく、現在では全く問題にならない量でしょう。
CPU性能にしても10年前と比べれば1桁以上違います。100万回の空ループが1秒かかりません。

データを全て配列に入れなくても、必要な都度読み込めば出来ないことはないけど、配列変数
なってると、処理が簡単になったり、(場合によっては)早くなったりするんです。


Re4:四角形と多角形の重なった図形  masafumi
email:  Sat Feb 19 22:00:49 2005

どもっ、石男さん。お久しぶりです。
私は半年ぶりに重複図形削除の Script を修正していたので、こちらの関係と同様のことか
と思いこんでいました。それと UP する時に下のメッセージを見落としていました。m(_ _)m


Re3:四角形と多角形の重なった図形   石男
email:  Sat Feb 19 17:54:39 2005

>masafumiさん
こちらこそ、ご容赦を...。幾何アルゴリズムかと思い、あれこれ思い悩んだ末の書き
込みだったものですから。構造体やら配列やらと大掛かりにしたらって感じでした。
試しに四角形と曲線の重なった図形もやってみたら、簡単に出来てしまいました。
なんだか、うれしいやら恥ずかしいやら...。


Re2:四角形と多角形の重なった図形  masafumi
email:  Sat Feb 19 17:04:30 2005

う〜ん、なんか間の抜けたレスになってしまった。(^_^;)
ご容赦を・・・。


Re1:四角形と多角形の重なった図形  masafumi
email:  Sat Feb 19 16:56:11 2005

こんにちは、masafumiです。

四角形と多角形が重なっているかを判断するんですよねぇ。
こんな感じでどうでしょうか。

- {先に四角形の頂点の座標と辺の角度を取得}
- {次に多角形の頂点の座標と辺の角度を取得}
- i:=1;
- endFlg:=False; {終了フラグを初期化}
- repeat
- i:=i+1; { i は四角形の頂点数}
- j:=1;
- repeat
- j:=j+1; { j は多角形の頂点数}
- if ((四角形の i の角度 = 多角形の j の角度) = ( 0 or 180 )) then
- begin
- if (四角形の i のY座標 = 多角形の j のY座標) then
- begin
- if ((四角形の i-1 のX座標) <= (多角形(j-1) and (j) のX座標) <= (四角形の i のX座標))or
- ((四角形の i-1 のX座標) >= (多角形(j-1) and (j) のX座標) >= (四角形の i のX座標))then
- begin
- {この状態の時、四角形の1辺と多角形の1辺は重なっている}
- endFlg:=True;
- end else endFlg:=False;
- end;
- end else if ((四角形の i の角度 = 多角形の j の角度) = ( 90 or -90 )) then
- begin
- if (四角形の i のX座標 = 多角形の j のX座標) then
- begin
- if ((四角形の i-1 のY座標) <= (多角形(j-1) and (j) のY座標) <= (四角形の i のY座標))or
- ((四角形の i-1 のY座標) >= (多角形(j-1) and (j) のY座標) >= (四角形の i のY座標))then
- begin
- {この状態の時も四角形の1辺と多角形の1辺は重なっている}
- endFlg:=True;
- end else endFlg:=False;
- end;
- end;
- until((endFlg=False) or (j=多角形の頂点数));
- until((endFlg=False) or (i=5));

{endFlg:=True の時、四角形と多角形は重なっていると判断できる}

※注意
上記の場合ですと四角形が多角形より小さい時には重なっていると認識しないので、先に四角形から
多角形を複製して、その図形と多角形の大きさを GetBBox で比較し、大きい図形の方を最初の repeat
に入れると上手くいくと思います。


Re.: 四角形と多角形の重なった図形   石男
email:  Sat Feb 19 14:45:06 2005

事故レスです、難しいことを考え過ぎていました...。
重なった図形 := IntersectSurface(多角形, 四角形);で返ってきました。
無駄に2日も考えていました。


四角形と多角形の重なった図形   石男
email:  Sat Feb 19 12:46:15 2005

を導き出す呪文を考えているのですが、どうも考えがまとまりません。
四角形の中にある多角形の頂点、多角形の中にある四角形の頂点、これらを全て拾い
出し、それぞれの頂点を含む辺同士の交点を求めてつなぎ合わせれば良い気がする
のですが...。


原点と用紙の中心座標を表示/設定する。   与太郎
email:  Fri Feb 18 18:09:50 2005

「原点指示...」コマンドで「用紙の中心」を設定したのに、原点(0,0)が用紙の中心に
ならない場合があります。理由は用紙の位置が移動しているからです。しかし、用紙が
元の位置からどれだけ移動しているかは、後からでは判りません。
また、用紙の位置を初期値に戻すコマンドもありません。
それで、原点と用紙中心を数字で表示/指定したり、初期値に戻すスクリプトを書いて
みました。

procedure GetPrintCenter;
{ 用紙の中心座標を表示(VW9以降) }
var
x, y, x0, y0, xc, yc :real;
upi :real;
fraction,
display :longint;
format :integer;
name, squareName :string;
begin{main}
GetOrigin(xc, yc);
GetUnits(fraction, display, format, upi, name, squareName);
x0:= GetPrefReal(68)*GetLScale(ActLayer)*upi - xc;
y0:= -GetPrefReal(69)*GetLScale(ActLayer)*upi - yc;
Message('用紙中心= ', x0, ', ', y0);
end;{main}
Run(GetPrintCenter);


procedure SetPrintCenter;
{ 用紙の中心を設定(VW9以降) }
var
x, y, x0, y0, xc, yc :real;
upi :real;
fraction,
display :longint;
format :integer;
name, squareName :string;
begin{main}
GetOrigin(xc, yc);
GetUnits(fraction, display, format, upi, name, squareName);
x0:= GetPrefReal(68)*GetLScale(ActLayer)*upi - xc;
y0:= -GetPrefReal(69)*GetLScale(ActLayer)*upi - yc;
PtDialog('用紙の中心 = ', Num2Str(9, x0), Num2Str(9, y0), x, y);
if not DidCancel then begin
SetPrefReal(68, (x+xc)/GetLScale(ActLayer)/upi);
SetPrefReal(69, -(y+yc)/GetLScale(ActLayer)/upi);
end;{if}
end;{main}
Run(SetPrintCenter);


procedure ResetPrintCenter;
{ 用紙の中心を初期状態に戻す(VW9以降) }
begin
SetPrefReal(68, 0);
SetPrefReal(69, 0);
end;
Run(ResetPrintCenter);


procedure GetVWOrigin;
{ 原点の設定値(本来の原点を中心とした座標)を表示 }
var
x, y :real;
begin
GetOrigin(x, y);
Message('原点= ', x, ', ', y);
end;
Run(GetVWOrigin);


procedure SetVWOrigin;
{ 原点を設定(本来の原点を中心として) }
var
x, y, x0, y0 :real;
begin{main}
GetOrigin(x0, y0);
PtDialog('原点 = ', Num2Str(9, x0), Num2Str(9, y0), x, y);
if not DidCancel then begin
SetOrigin(x-x0, y-y0);
end;{if}
end;{main}
Run(SetVWOrigin);


procedure ResetVWOrigin;
{ 原点を初期状態に戻す=「原点指示...」コマンドの「用紙の中心」と同じ }
var
x, y :real;
begin
GetOrigin(x, y);
SetOrigin(-x, -y);
end;
Run(ResetVWOrigin);


Re:座標の取り出し   与太郎
email:  Wed Feb 16 19:02:36 2005

紅芋さん、はじめまして。
>scriptを用いて座標から線を引いて図形を描くことができるようなので
>その逆も可能かと思われるのですが、どうでしょうか。
一部を除いてほとんどの情報をスクリプトで取り出せます。
やり方は、図形の種類、図形の指定方法、情報の書き出し先によって違います。

>古いバージョンではできるが、新しいのではできないという噂を聞いたこともあります。
そんなことはありません。基本的に、新しいバージョンほど制限は少ないです。

それから、VectorScript形式で書き出して、Excelなどで数値だけ取り出す方法もあります。
Layer(XXX); から次の Layer(YYY); までがそのレイヤ(XXX)内の記述で、
{Object Creation Code} から下が図形生成コマンドです。
属性指定コマンドが混じっていますが、どの行がどの図形(種類)かは判ると思います。
(コマンドの説明は、Vector Script Reference.pdf にあります)


座標の取り出し   紅芋
email:
YIV01525@nifty.com  Wed Feb 16 16:10:23 2005

はじめまして。
vector worksでどうしても分からないことがあり、
検索しているうちにここに行き着きました。

質問内容ですが
2次元の図形を描いた後、各点の座標を取り出したいのですが
やり方が分かりません。
scriptを用いて座標から線を引いて図形を描くことができるようなので
その逆も可能かと思われるのですが、どうでしょうか。
現在vector works 9.5を使用しています。
古いバージョンではできるが、新しいのではできないという噂を聞いたこともあります。

もし何かわかることがありましたら、どなたかよろしくお願いします。


円弧はいやだ...   石男
email:  Wed Feb 9 15:30:09 2005

円弧の建物はいやだ...と思いながらこんなの作ってみました...。Tool Plugin用に
なっています。

{*******************************************
半径と弦の長さ、もしくは円弧の長さを指定して
傾いた円弧を書きます

1点目と2点目で円弧の傾きを指示します。
*******************************************}

Procedure CGREnko ;

Var
struct_2DMatrix , struct_2DMatrix2 , rm : ARRAY[ 1..2 , 1..2 ] of Real ;
radius , gen , enko , angular , tawami , startangle , ag : Real ;
cp , cp1 , p1 , p2 , kcp , cv : Vector ;
genorko : Boolean ;
{-----------半径&弦で円弧を求める-------------}
Procedure GR_Enko( G , R : Real ; Var C , Q , T : Real ) ;
Begin
C := ( PI*R*( Rad2Deg( ArcSin( G/( 2*R ) ) ) ) )/ 90 ;
Q := 2*( Rad2Deg( ArcSin( G/( 2*R ) ) ) ) ;
T := R*( 1-Cos( Deg2Rad( Rad2Deg( ArcSin( G/( 2*R ) ) ) ) ) ) ;
End ;

{-----------半径&弧長で円弧を求める-------------}
Procedure CR_Enko( C , R : Real ; Var G , Q , T : Real ) ;
Begin
G := 2*R*Sin( Deg2Rad( ( 90*C)/( PI*R ) ) ) ;
Q := ( 180*C )/( PI*R ) ;
T := R*( 1-Cos( Deg2Rad( ( 90*C)/( PI*R ) ) ) ) ;
End ;

FUNCTION directD ( x0, y0, x1, y1 : REAL ) : REAL;
LABEL
9999;
VAR
dx, dy : REAL;
anan : REAL;
BEGIN
dx := x1 - x0;
dy := y1 - y0;
IF ( dx = 0 ) and ( dy = 0 ) THEN
BEGIN
anan := -1;
GOTO 9999;
END;
IF Abs ( dx ) > abs ( dy ) THEN
BEGIN
anan := ArcTan ( dy / dx ) * 180.0 / PI;
IF dx < 0 THEN
anan := anan + 180.0;
END
ELSE
BEGIN
anan := 90.0 - ArcTan ( dx / dy ) * 180.0 / PI;
IF dy < 0 THEN
BEGIN
anan := anan + 180.0;
END;
END;
IF anan < 0 THEN
BEGIN
anan := anan + 360.0;
END
ELSE IF anan >= 360.0 THEN
BEGIN
anan := anan - 360.0;
END;
9999:
directD := anan;
END;

{-----------Init_2DMatrix 2Dマトリックス初期化--------}
Procedure Init_2DMatrix( m2DMat : ARRAY[ 1..2 , 1..2 ] of Real ; Var initm2DMat : ARRAY[ 1..2 , 1..2 ] of Real ) ;
Begin
m2DMat[ 1 , 1 ] := 1 ; m2DMat[ 1 , 2 ] := 0 ;
m2DMat[ 2 , 1 ] := 0 ; m2DMat[ 2 , 2 ] := 1 ;
initm2DMat := m2DMat ;
End ;
{----------Apply2DVec2DMat 2Dマトリックスとベクトルの掛け算------}
Procedure Apply2DVec2DMat( p2D : Vector ; m2DMat : ARRAY[ 1..2 , 1..2 ] of Real ; Var p2DApp : Vector ) ;
Begin
p2DApp.x := m2DMat[ 1 , 1 ]*p2D.x + m2DMat[ 1 , 2 ]*p2D.y ;
p2DApp.y := m2DMat[ 2 , 1 ]*p2D.x + m2DMat[ 2 , 2 ]*p2D.y ;
End ;
{----------Multi2DMat 2Dマトリックスと同志の掛け算------}
Procedure Multi2DMat( m1 , m2 : ARRAY[ 1..2 , 1..2 ] of Real ; Var m3 : ARRAY[ 1..2 , 1..2 ] of Real ) ;
Begin
m3[ 1 , 1 ] := m1[ 1 , 1 ]*m2[ 1 , 1 ] + m1[ 1 , 2 ]*m2[ 2 , 1 ] ;
m3[ 2 , 1 ] := m1[ 2 , 1 ]*m2[ 1 , 1 ] + m1[ 2 , 2 ]*m2[ 2 , 1 ] ;
m3[ 1 , 2 ] := m1[ 1 , 1 ]*m2[ 1 , 2 ] + m1[ 1 , 2 ]*m2[ 2 , 2 ] ;
m3[ 2 , 2 ] := m1[ 2 , 1 ]*m2[ 1 , 2 ] + m1[ 2 , 2 ]*m2[ 2 , 2 ] ;

End ;
{---------Rot2DMat 2Dの回転マトリックス----------------------}
Procedure Rot2DMat( Ag : Real ; Var mr2DMat : ARRAY[ 1..2 , 1..2 ] of Real ) ;
Begin
mr2DMat[ 1 , 1 ] := Cos( Deg2Rad( Ag ) ) ;
mr2DMat[ 1 , 2 ] := -Sin( Deg2Rad( Ag ) ) ;
mr2DMat[ 2 , 1 ] := Sin( Deg2Rad( Ag ) ) ;
mr2DMat[ 2 , 2 ] := Cos( Deg2Rad( Ag ) ) ;
End ;


{-----------------Rot2DVec 回転角度、座標で回転後の座標を返す------------------------}
Procedure Rot2DVec( Ag : Real ; v0 : Vector ; Var v1 : Vector ) ;
Var
rotate2DM : ARRAY[ 1..2 , 1..2 ] of Real ;
Begin
Rot2DMat( Ag , rotate2DM ) ;
Apply2DVec2DMat( v0 , rotate2DM , v1 ) ;
End ;

{*******ベクトル上に長さの違うベクトルを作る*****}
Function VecOnVec( s_dp , dp : Vector ; mov : Real ) : Vector ;
Var
myNorm , vecAngle : Real ;
pp : Vector ;
Begin
myNorm := Norm( dp ) ;
vecAngle := Vec2Ang( dp ) ;
pp := Ang2Vec( vecAngle , mov ) ;
VecOnVec := pp + s_dp ;
End ;

{=================Main===================}
Begin
radius := PRADIUS{80} ;
genorko := PGENORKO ;{--true=弦指定 false=円弧指定---}
enko := PENKO{50} ;
gen := PGEN{50} ;
GetPt( cp1.x , cp1.y ) ;{-----------空クリック----------}

GetPt( cp1.x , cp1.y ) ;
GetPtL( cp1.x , cp1.y , kcp.x , kcp.y ) ;
cv := kcp-cp1 ;

cp := VecOnVec( cp1 , cv , radius ) ;
cv := cp1-cp ;
If genorko = true Then
Begin
enko := 0 ;
GR_Enko( gen , radius , enko , angular , tawami ) ;
End Else
If genorko = false Then
Begin
gen := 0 ;
CR_Enko( enko , radius , gen , angular , tawami ) ;
End ;
Init_2DMatrix( struct_2DMatrix , struct_2DMatrix ) ;{-----------2Dマトリックス初期化--------}
Rot2DVec( -angular/2 , cv , p1 ) ;{---------回転角度、座標で回転後の座標を返す--------------}
Init_2DMatrix( struct_2DMatrix , struct_2DMatrix ) ;{-----------2Dマトリックス初期化--------}
Rot2DVec( angular/2 , cv , p2 ) ;{---------回転角度、座標で回転後の座標を返す--------------}
p1 := p1 + cp ;
p2 := p2 + cp ;
startangle := directD ( cp.x , cp.y , p1.x , p1.y ) ;
ArcByCenter( cp.x , cp.y , radius , startangle , angular ) ;
MoveTo( cp.x , cp.y ) ;{--------------弦-------------}
LineTo( cp1.x , cp1.y ) ;
MoveTo( p1.x , p1.y ) ;{--------------半径-------------}
LineTo( p2.x , p2.y ) ;


End ;
Run( CGREnko ) ;

directDはA+AのOpenTipsです、これを利用して商売してはいけません。


MATRIX 3  与太郎
email:  Tue Feb 8 20:17:29 2005

(先週からのつづき)
ポリゴンが四角形では不都合なので、三角形に分割する必要もあります。
四角形の分割は、下のように色々なパターンが考えられますが、

・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・
│/│/│/│ │\│\│\│ │/│/│/│ │/│\│/│ │/│\│/│
・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・
│/│/│/│ │\│\│\│ │\│\│\│ │/│\│/│ │\│/│\│
・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・
│/│/│/│ │\│\│\│ │/│/│/│ │/│\│/│ │/│\│/│
・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・ ・─・─・─・

面倒なので、真ん中に点を作って4分割することにしました。

・─・─・─・
│×│×│×│×
・─・─・─・─・
│×│×│×│×│×
・─・─・─・─・─・
│×│×│×│×│×
・─・─・─・─・

中心の高さは周りの4点の高さの平均です。中心の座標も簡略化のため、対角線の交点では
なく、4点の平均にしました。周りに3点しかない場合は、対角線の中心の座標と高さにし
ます。本当は3点のときは分割する必要はありませんが、スクリプトを単純にするために分
割します。


1─────2
│\ ・ /│
│ \ / │
│・ 0 ・│
│ / \ │
│/ ・ \│
4─────3

具体的には1〜4の配列要素のハンドルをカウントして、3個以上あれば処理し、それ以下
なら無視します。
3D基準点から3D多角形を生成するスクリプトは下のような感じになります。
(記憶頼りで書いてるので,細かいところは違うかも)

var
_h_:array[1..5] of handle;{ コード単純化のため、1のデータを5にも入れる }
_x, y, z_:array[0..5] of real;



GetOrigin(xc, yc);
for iX:= 0 to MaxArrayX-1 do begin
_for iY:= 0 to MaxArrayY-1 do begin
__h[1]:= hP[iX, iY];
__h[2]:= hP[iX+1, iY];
__h[3]:= hP[iX+1, iY+1];
__h[4]:= hP[iX, iY+1];
__h[5]:= h[1];
__n:= 0;
__for i:= 1 to 4 do
___if h[i] <> nil then
____n:= n + 1;
__if 3 <= n then begin
___for i:= 1 to 5 do
____if h[i] <> nil then begin
_____GetLocus3D(h[i], x[i], y[i], z[i]);
_____x[i]:= x[i] - xc;
_____y[i]:= y[i] - yc;
____end;{if}
___end;{for}
___
___{ 中心座標を計算 }
___if (h[1] <> nil) & (h[3] <> nil) then begin
____x[0]:= (x[1] + x[3])/2;
____y[0]:= (y[1] + y[3])/2;
____z[0]:= (z[1] + z[3])/2;
____if (h[2] <> nil) & (h[4] <> nil) then begin
_____x[0]:= (2 * x[0] + x[2] + x[4])/4;
_____y[0]:= (2 * y[0] + y[2] + y[4])/4;
_____z[0]:= (2 * z[0] + z[2] + z[4])/4;
____end;{if}
___end{if}
___else if (h[2] <> nil) & (h[4] <> nil) then begin
____x[0]:= (x[2] + x[4])/2;
____y[0]:= (y[2] + y[4])/2;
____z[0]:= (z[2] + z[4])/2;
___end;{else}
___
___{ 3D多角形を生成 }
___for i:= 1 to 4 do begin
____if (h[i] <> nil) & (h[i+1] <> nil) then begin
_____BeginPoly3D;
______Add3DPt(x[0], y[0], z[0]);
______Add3DPt(x[i], y[i], z[i]);
______Add3DPt(x[i+1], y[i+1], z[i+1]);
_____EndPoly3D;
____end;{if}
___end;{for}
__end;{if}
_end;{for}
end;{for}

最初のデータ(文字と円)からの変換でも、実行時間は1分以内でした。
このデータから切断面を作るのは手作業になりますが、他の方法で断面を切るよりは簡単で
しょう。法線の他に適当な角度を持たせた補助線も3D化しておけば、断面の作り忘れや重複
の発見も容易です。

今回は基準点がほぼ整列していたので、単純なスクリプトで済みましたが、基準点がランダムに
並んでいた場合は、全然別のアプローチが必要でしょう。
(おわり)


図形カウントの件  tucky
email:  Tue Feb 8 11:00:13 2005

まだ試してはいませんが、大丈夫でしょうから先にお礼を述べさせていただきます。

与太郎さん。早速の回答ありがとうございます。

私もがんばって、与太郎さんのように上達したいと思います。
(VSで四角形だけ書くことができる程度の腕前ですので・・・)

機会がありましたら、また助けてください。
ありがとうございました。


Re:図形をカウントするVS。   与太郎
email:  Mon Feb 7 18:12:17 2005

tuckyさん、はじめまして。
図形を数える方法は何種類かあります。

まずは図形選択コマンドを改造する方法です。
Altキーを押しながらコマンドをダブルクリックするとスクリプト編集画面になるので、
SelectObj(( を Message(Count( に変えます。

SelectObj((T=LINE)); → Message(Count(T=LINE));

文章も付け加えたいときは下のようにします。

Message('ファイル内の直線は ' , Count(T=LINE), ' 個です。');


Count関数でアクティブレイヤを指定するには、変数を使わないといけません。

procedure count2;
var
_name_:string;
_c_:longint;
begin
_name:= GetLName(ActLayer);
_c:= Count((L=name) & (SEL=TRUE));
_Message('アクティブレイヤの選択図形は ' , c, ' 個です。');
end;
Run(count2);


Count関数を使うと、グループ内の図形も数えてしまいます。
グループ内の図形を数えたくなければ、下のようにします。

procedure count3;
const
_LineObj = 2;
var
_h_:handle;
_c_:longint;
begin
_c:= 0;
_h:= ActLayer;
_while h <> nil do begin
__if GetType(h) = LineObj then begin
___c:= c + 1;
__end;{if}
__h:= NextObj(h);
_end;{while}
_Message('アクティブレイヤの直線は ' , c, ' 個です。');
end;
Run(count3);


procedure count4;
const
_LineObj = 2;
var
_h, hL_:handle;
_c_:longint;
begin
_c:= 0;
_hL:= FLayer;
_while hL <> nil do begin
__h:= ActLayer;
__while h <> nil do begin
___if GetType(h) = LineObj then begin
____c:= c + 1;
___end;{if}
___h:= NextObj(h);
__end;{while}
__hL:= NextLayer(hL);
_end;{while}
_Message('ファイル内のの直線は ' , c, ' 個です。');
end;
Run(count4);

だいたい上のような感じです。
それから、スクリプトの"_"(全角下線)は、タブか空白に置き換えないと実行できません。


図形をカウントするVS。  tucky
email:  Mon Feb 7 12:44:39 2005

winXP VW8(古くてすみません)
VW(miniCAD)暦、7年。VS初心者です。

図形をカウントし、画面にメッセージボックスとして表示させる(" "個あります。みたいな・・・)scriptを何度か挑戦してみましたが、全くできそうにありません。

どなたか、助けていただけませんでしょうか。


MATRIX 2  与太郎
email:  Mon Jan 31 22:15:17 2005

(先週からのつづき)
翌日の日曜日はお休みして、月曜日にリロードしました。
方針を変更して、自分でポリゴン(3D多角形)を作るしかないようです。どうやって隣同士
の点を結んでばポリゴンを作ればいいのでしょうか?

1─2─3─4
│ │ │ │
5─6─7─8
│ │ │ │
9─10─11─12
│ │ │ │
13─14─15─16

たとえば点(1)を基準にして(1)-(2)-(6)-(5)の四角形を作る場合、点(2),(6),(5)を見つける
必要があります。要するに、隣の点を探すのですが、
1. GetPtでマウスクリックして、PickObjectで点を取る。
2. 全ての点の座標を調べて、目的の点を探す。
3. 基準となる点からPickObjectで点を取る。
4. あらかじめ点のハンドルを2次元配列に入れておく。
などの方法を考えましたが、
1.はコードは簡単そうですが、点の数が多いと実用的とはいえません。
2.は実行時間がかかりそうです。
3.は確実に点が取れるか自信が持てません。また実行時間も早いとはいえません。
というわけで、4.の方法が適しているようです。これなら隣り合った点を見つけるのは簡単
です。ある点(1)のハンドルがh[x,y]だとすると、点(2),(6),(5)のハンドルは、h[x+1,y]、
h[x+1,y+1]、h[x,y+1]で求まり、事実上時間はかからないでしょう。

Y\X(0)(1)(2)(3)
(0)1─2─3─4
・・・│ │ │ │
(1)5─6─7─8
・・・│ │ │ │
(2)9─10─11─12
・・・│ │ │ │
(3)13─14─15─16

配列に3D基準点のハンドルを入れるのは、幸い点がほぼ等間隔に並んでいるので簡単です。
XとYの最小値と最大値、XとYの配列の大きさを、インターフェースを省略するために定数に
しておきます(自分が使うだけですし)。点が配列のどこに入るかは、簡単に計算できます。

dX:= (MaxX-MinX)/MaxArrayX;
dY:= (MaxY-MinY)/MaxArrayY;


{ 3D基準点を配列に格納 }
h:= FActLayer;
while h <> nil do begin
_GetLocus3D(h, x, y, z);
_iX:= Round((x-MinX)/dX);
_iY:= Round((y-MinY)/dY);
_hP[iX, iY]:= h;
_h:= NextObj(h);
end;

同様にして、最初のデータから3D基準点を作ってみました。

{ 円と文字のハンドル&中心座標を配列に格納 }
h:= FActLayer;
while h <> nil do begin
_HCenter(h, xc, yc);
_iX:= Round((xc-MinX)/dX);
_iY:= Round((yc-MinY)/dY);
_Case GetType(h) of
__PolylineObj: begin
___hP[iX, iY]:= h;
___x[iX, iY]:= xc;
___y[iX, iY]:= yc;
__end;
__TextObj: begin
___Case GetTextSize() of
____6: hTR[iX, iY]:= h;
____8: hTL[iX, iY]:= h;
___end;
__end;
_end;
_h:= NextObj(h);
end;
{ 3D基準点を生成して配列に格納 }
for iX:= 0 to MaxArrayX do begin
_for iY:= 0 to MaxArrayY do begin
__if (hP[iX,iY] <> nil) & (hTL[iX,iY] <> nil) & (hTR[iX,iY] <> nil) then begin
___s:= Concat(GetText(hTL[iX, iY]), '.', GetText(hTR[iX, iY]));
___Locus3D(x[iX, iY], y[iX, iY], Str2Num(s));
___DelObject(hP[iX, iY]); DelObject(hTL[iX, iY]); DelObject(hTR[iX, iY]);
__end;
_end;
end;

今回は十数秒で出来てしまいました。そして最初のスクリプトとは違って、3D基準点は左上
から順番に生成されます。結果的にはビン・ソートを実行したのと同じことになりました。
ビン・ソートは、一定の条件内では最も速いソートです。この問題は図らずもビン・ソート
に適していたようです。なんで最初に思い付かなかったかなぁ。

仕事の合間にチョコチョコやって、ここまで進みました。配列にハンドルを入れてしまえば
あとは簡単(な筈)です。残りは帰ってからにしましょう。
(つづく)


Re:禁断の...   与太郎
email:  Sun Jan 30 18:37:34 2005

ランドマークだけではなくアーキテクトも当然持ってませんので、その実力を窺い知る
ことは叶いませんが...
人間が目で見れば、どの点とどの点を結んで三角形にすればいいかは一目瞭然なのに、
それをプログラムで勝手にやらせるのは物凄く大変なんですよね。OCRやラス→べク変
換にもいえることですが、人間のパターン認識能力って本当に凄いですね。
不完全にしろ、それをプログラムで書いちゃう人がいるっていうのも凄いですけど。


禁断の...   石男
email:  Sat Jan 29 8:26:01 2005

>与太郎さん
これは実は禁断の果実?だったりします。以前に確かVW8あたりに地形を作成するもの
があったと思いますが、頂点が多いと確実に死にます。マニュアル程度に書かれている
くらいのものは出来ましたが...。
同じ様なものを自作した記憶がありますが、配列の壁にぶち当たり不完全でした。
それと頂点が多いからといって分割してみると思いのほか面倒です。
という訳で途中で挫折しました...。
ちなみにランドマークだけではなくアーキテクトでも地形生成ができたはずです。
ただどこまで出来るのかは定かではありません!


MATRIX  与太郎
email:  Fri Jan 28 22:36:35 2005

シンボルの反転は、SDKではGetEntityMatrixで調べるようですが、Matrixなんて判らないし、
そもそもSDKをやらないので意味がないし。
ところでMatrixといえば...

(以下独り言です)
■メッシュ状の平面データから断面の地盤線を作れないかと訊かれたんで、断面がメッシュに
重なってれば簡単に出来ますと答えたけど、詳しく聞くとメッシュと断面は重なってなくて、
角度が直角(平行)でない箇所もあるらしい。しかもデータを見たら3Dデータではなく、数値
で高さを表してる平面図で、小数点以上の数字、小数点、小数点以下の数字に分解されていま
した。(「10」「.」「6」のような具合。小数点は文字でなく円。下のようなかんじで1万個
以上並んでいます。しかも各々の間隔が微妙に違います。データが重くてAutoCADの画面がな
かなか表示されません。よくみたら文字がTrueTypeフォントでした。)

12.5 12.8 13.1 13.6

12.7 13.0 13.4 13.8

12.9 13.3 13.7 14.0

13.2 13.6 13.9 14.2

このデータを見て、正直、あんまりやりたくないなぁと思いました。
■別にコンターのデータもあるらしいので、そっちのデータを使ったほうが早いです、手作業
ですけどって言ったら、ちょっと考えてみますという返事。たぶん社内でやってしまうんだな
と思いましたが、週末なのでとっとと帰りました。
■でも休日に考えました。VWでコンターから断面を作る方法は判るけど、AutoCADやJW-CAD
ではどうやるんだろうかと。しかしAutoCADやJW-CADは詳しく知らないので、良い方法は思い
付きませんでした。いずれにしても、何十箇所も手作業でやるのは大変だと思い、実際に作業
する人がちょっと気の毒になりました。
■しかし、もしかしたら自分がやる羽目になる可能性もあります。気の毒な人になりたくない
ので、簡単に出来る方法はないか考えることにしました。
■結局、3D地盤を作って切断面を作るのが単純でミスも少ないだろうということに落ち着いた
のですが、問題は3D地盤をどう作るかです。ランドマークなど持っていないのでスクリプトで
やるつもりでしたが、方針は決まりません。とりあえず3D基準点に変換することにしました。
データが順番に並んでいるとは期待できないので、ハンドルを順番に3個ずつ取って...という
のは問題外です。X,Y座標は円の中心でいいのですが、Y座標を求めるには、円の左右の文字を
調べる必要があります。そのためには、円の左右の文字を見つけないといけません。
■円と文字の距離は決まってるようなので、円の中心から一定の範囲内にある文字を見つけれ
ばいいのですが、片っ端から調べていくと何十分(何時間か?)も掛かってしまいます。一度
しか実行しないのでそれでも構わないとはいえません。デバッグのことを考えれば必ず何回か
実行することになります。かといって、データのハンドルを座標でソートするのも気が進みま
せんでした。使い捨てのスクリプトなのでソート・コードを調べるたりするのが面倒だし、並
びが微妙に水平・垂直でないので、ソートするにも一工夫必要な気がしたので。それで、円の
中心から一定の距離で、PickObjectで文字のハンドルを取ることにしました。この方法だとス
クリプトがとても簡単になります。思ったとおり10分くらいで書きあがりました。

h:= LActLayer;
while h <> nil do begin
_if GetType = PolyLineObj then begin
__HCenter(h, x, y);
__hL:= PickObject(x-3.0, y+1.0);
__hR:= PickObject(x+2.0, y);
__if (hL<>nil) & (hR<>nil) & (GetType(hL)=TextObj) & (GetType(hR)=TextObj) then begin
___s:= Concat(GetText(hL), '.', GetText(hR));
___Locus3D(x, y, Str2Num(s));
___DelObject(h);
___DelObject(hL);
___DelObject(hR);
__end;
_end;
_h:= PrevObject(h);
end;

■ですが、実行してみて判ったのは、PickObjectを1万回も実行すると結構時間がかかるとい
うことでした。G4/500で20分くらいかかりましたが、1回目は単位を間違えていたため何も変
換されませんでした。2回目は距離の設定が悪かったのか、完全には変換されませんでした。
何度か距離を調節しながら実行して、なんとか全部3D基準点に返還できました。
■変換したデータで、試しにVW8.5で3D化に挑戦してみましたが、計算が終わる前にVWが落ちま
した。データを半分にしても、1/4にしても、まだ落ちました。これ以上分割しても面倒になる
だけだと思い、
とりあえずあきらめて寝ました(爆)。
(来週につづく)


Re2: 図形をシンボルに置き換え   与太郎
email:  Fri Jan 28 8:18:22 2005

>シンボルの反転を区別する方法
シンボルを分解して、シンボル定義の中身と比べてみれば、判断できる場合もあるでしょうね。
(中のデータによります。いえ、もちろんそこまでやる気はないですよ。)


Re.: 図形をシンボルに置き換える   石男
email:  Thu Jan 27 17:01:13 2005

>シンボルの反転までは再現できませんでした。(あぁ悲しい。)
ミラー反転、ミラー反転複写は手動のみですよ、きっと。確かデータ表示が元図形と
一緒で区別が出来ないはずです。この件で答えにならない返事を貰った記憶があります


図形をシンボルに置き換える   与太郎
email:  Wed Jan 26 20:30:24 2005

図形をシンボルに置き換えるスクリプトです。
置き換えるシンボルは、実行前にリソースプラウザ(パレット)で指定しておきます。

データパレットの「置き換え...」のように、シンボルの置き換えも出来ます。
データパレットで置き換えると、レコード情報が消えてしまって悲しい思いをしますが、
下のスクリプトだとレコード情報は保持されます。
でも、シンボルの反転までは再現できませんでした。(あぁ悲しい。)

procedure Obj_To_Sym;
{ クリックした図形をデフォルトのシンボルと置き換える。 }
{ 置き換えの基準点は図形の中心。ただしシンボルの場合はシンボル基点を合わせる。 }
const
_SymObj = 15;
var
_hS, h_:handle;
_symName_:string;
_x, y_:real;

procedure Obj2Sym(h, hS:handle);
{ 図形(h)をシンボル(hS)に置き換えます。 }
var
_name_:string;
_lName, cName_:string;
_x, y, xc, yc, rot_:real;
_x1, y1, x2, y2_:real;
_
_procedure CopyRec(h1, h2:handle);
_var
__hRec_:handle;
__nRec, nFld_:integer;
__recName, fldName, value_:string;
__i, j_:integer;
_begin
__nRec:= NumRecords(h1);
__for i:= 1 to nRec do begin
___hRec:= GetRecord(h1, i);
___recName:= GetName(hRec);
___SetRecord(h2, recName);
___nFld:= NumFields(hRec);
___for j:= 1 to nFld do begin
____fldName:= GetFldName(hRec, j);
____value:= GetRField(h1, recName, fldName);
____SetRField(h2, recName, fldName, value);
___end;{for}
__end;{for}
_end;{CopyRec}
_
begin
_name:= GetName(h);
_lName:= GetLName(GetLayer(h));
_cName:= GetClass(h);
_if GetType(h) = SymObj then begin
__GetSymLoc(h, xc, yc);
__rot:= GetSymRot(h);
_end{if}
_else begin
__GetBBox(h, x1, y1, x2, y2);
__xc:= (x1 + x2) / 2; yc:= (y1 + y2) / 2;
__Rot:= 0;
_end;{else}
_Layer(lName);
_NameClass(cName);
_Symbol(symName, xc, yc, rot);
_hS:= LNewObj;
_SetDSelect(hS);
_if GetType(h) <> SymObj then begin
__GetBBox(hS, x1, y1, x2, y2);
__x:= (x1 + x2) / 2; y:= (y1 + y2) / 2;
__HMove(hS, xc-x, yc-y);
_end;{if}
_CopyRec(h, hS);
_DelObject(h);
_SetName(hS, name);
end;{Obj2Sym}

begin{main}
_PushAttrs;
_hS:= ActSymDef;
_if (hS = nil) then begin
__AlrtDialog('リソースパレット(プラウザ)でシンボルを指定してから実行して下さい。');
_end{if}
_else begin
__symName:= GetName(hS);
__Message('シンボルに置き換える図形をクリックしてください。');
__GetPt(x, y);
__h:= PickObject(x, y);
__while h <> nil do begin
___Obj2Sym(h, hS);
___ReDraw;
___GetPt(x, y);
___h:= PickObject(x, y);
__end;{while}
_end;{else}
_ClrMessage;
_PopAttrs;
end;
Run(Obj_To_Sym);


procedure SelObj_To_Sym;
{ 選択された図形をデフォルトのシンボルと置き換える。 }
{ 置き換えの基準点は図形の中心。ただしシンボルの場合はシンボル基点を合わせる。 }
const
_SymObj = 15;
var
_hS, h, hN_:handle;
_symName_:string;
_lName_:string;

{ 上のスクリプトの procedure Obj2Sym 〜 end;{Obj2Sym} をここにコピーします。}

begin{main}
_PushAttrs;
_lName:= GetLName(ActLayer);
_if Count((L=lName)&(SEL=TRUE)) = 0 then begin
__AlrtDialog('アクティブレイヤの図形を選択してから実行して下さい。');
_end{if}
_else begin
__hS:= ActSymDef;
__symName:= GetName(hS);
__if (hS = nil) then begin
___AlrtDialog('シンボルが指定されていません。');
__end{if}
__else begin
___h:= FSActLayer;
___while h <> nil do begin
____hN:= NextSObj(h);
____Obj2Sym(h, hS);
____h:= hN;
___end;{while}
___ReDrawAll;
__end;{else}
_end;{else}
_PopAttrs;
end;
Run(SelObj_To_Sym);


Re:VectorScriptReferenceヘルプの日本語化について   与太郎
email:  Wed Jan 26 10:37:33 2005

上書きでも支障ありませんが、
元のフォルダを退避しとくほうが望ましいかと。


Re7:登録シンボル削除   石男
email:  Wed Jan 26 9:09:00 2005

> なんだか凄く高度なことをされてるような気が...
以前から3D版のものさしツールを自作しています。CallToolで3D基準点を2つ打たせて
そのx,y,zの差を求めるだけのものなのですが、10.5あたりからTool PlugIn内で
やるとバグが発生しまして...。そのため、CallTool(3D基準点)に代わる3次元入力方法
を考えると、3Dシンボルを配置するしかないのです。かなり、面倒になりましたが
このツールがないと仕事に支障?をきたすものですから(笑い)



VectorScriptReferenceヘルプの日本語化について  hide
email:
hvector2005@yahoo.co.jp  Wed Jan 26 8:51:29 2005

ありがとうございます
「VectorScript Reference」を上書きしてしまったのですが、問題あるのでしょうか?


Re:VectorScriptReferenceヘルプの日本語化について   与太郎
email:  Tue Jan 25 22:08:08 2005

上書きしなくてもVSFunctionReference.htmlを直接開けばいいのでは?
私はDockやタスクバーに登録しています。


Re6:登録シンボル削除   与太郎
email:  Tue Jan 25 22:06:50 2005

なんだか凄く高度なことをされてるような気が...


VectorScriptReferenceヘルプの日本語化について  hide
email:
hvector2005@yahoo.co.jp  Tue Jan 25 17:53:54 2005

A&Aのホームページから以下のファイルを上書きしたのですが日本語化になりません。
対策をどなたか教えて下さい

「VectorWorks11J」アプリケーションフォルダ内の「VWHelp」にある「VectorScript Reference」を和訳したHTML形式のファイルです。ファイルを上書きするとヘルプを選択した際に、日本語のマニュアルでご覧頂けます。

ファイル名 Vers. 作成日
VectorScript Reference 改訂第1版 04.07.30 ダウンロード
(vsref.zip/468KB)



Re5:登録シンボル削除   石男
email:  Mon Jan 24 21:25:24 2005

>たびたびすみません、与太郎さん
リロードせず書き込みしたら、与太郎さんの方が先でした...。
バグ回避のため苦肉の策で3Dシンボル生成しなきゃならないため、痕跡を残さないため
その3Dシンボルを削除といった仕掛けなのでタイプの調査はなしで大丈夫です。
3D用GetPtを作って欲しい...、そうすれば苦肉の策をせずに済むのに。


Re4:登録シンボル削除   与太郎
email:  Mon Jan 24 20:43:59 2005

>石男さん
どういたしまして。

>procedure DelSymDef
ハンドルがNILかどうかと、ハンドルのタイプを調べるのを忘れてます。


Re:登録シンボル削除   石男
email:  Mon Jan 24 17:41:48 2005

>与太郎さん
ありがとうございました。
GetObject( 'シンボル定義の名前' )でハンドルを取ってDelObjectにそのハンドルを渡
したら、無事登録シンボルが削除出来ました。DelObjectの説明には登録シンボルがな
かったので試していませんでした...。ちなみにDelNameは必要ないみたいです。
やりたいことはちょっとなのにバグ回避のため仕掛けが大きくなってしまいました。


Re2:登録シンボル削除   与太郎
email:  Mon Jan 24 17:37:07 2005

登録シンボルを削除するスクリプトは、下のようになります。
シンボル名はVWが削除してくれるので、ユーザーが削除する必要はありません。
使用中の登録シンボルを削除すると、シンボルが3D基準点に置き換わります。
(リソースパレット/プラウザから削除したときと同じでした。)

procedure test;

procedure DelSymDef(name:string);
{ 登録シンボルを削除する。使用中なら削除しない。 }
var
_h_:handle;
begin
_if (Count(S=name) = 0) then begin
__h:= GetObject(name);
__DelObject(h);
__AlrtDialog(Concat('「', name, '」を削除しました。'));
_end{if}
_else begin
__AlrtDialog(Concat('「', name, '」は使用しているので削除しません。'));
_end;{else}
end;{DelSymDef}

begin{test}
_DelSymDef('Symbol1');
end;
Run(test);


Re:登録シンボル削除   与太郎
email:  Mon Jan 24 10:25:04 2005

GetObject('シンボル定義の名前')でハンドルを取って消せませんか?
確認はしてませんけど。
削除したら、DelNameで名前を消す必要もあるかも。
使用中のシンボル定義を削除したらまずいでしょうね。
(どうなるか興味はありますが)


登録シンボル削除   石男
email:  Mon Jan 24 9:26:14 2005

アクティブドキュメントに登録されているシンボルをVSを使って削除する方法ってあり
ますか?登録や変更は可能なのですが、削除が出来ません。


Re3:SetCursorについて   与太郎
email:  Fri Jan 21 22:27:05 2005

procedure test;
{ Command(Ctrl)+「.」か「Esc」で終了します。 }
var
x,y:real;
i:integer;
begin
i:= -32768;
SetCursor(i);
Message('i=', i);
while (i < 32767) do begin
i:= i + 1;
SetCursor(i);
Message(i);
end;{while}
end;
Run(test);

上のスクリプトを走らせると、i=1307〜1312でカーソルが(一瞬ですが)変わります。
(確認するなら、i=1000あたりから始めたほうがいいです)
単純なリソース参照なら、他にもカーソルが変わる箇所があるはずですが、そうではないので、SetCursorは1307〜1312以外の引数をは受け付けない仕様だと思われます。
それから、SetCursorの内部で1307〜1312を本当のリソースIDに変換している可能性はありますね。
何故、引数が0〜5とか1〜6でないのかは判りませんが、初期のバージョンではリソースIDだった
のかも知れません。

やはりVectorScriptでは無理のようです。


Re:SetCursorについて   石男
email:  Fri Jan 21 17:01:23 2005

>これもSDKの領分ですね。
SDKでPlugInを作る時絶対にリソースが必要になるので、こちらのが手軽?ですね。
それにしてもVW本体のカーソルIDとHandC等のIDらしきものが違う番号なのだろうか。
どこかにあるのかな...。


Re:SetCursorについて   与太郎
email:  Fri Jan 21 8:22:41 2005

だめですか...
これもSDKの領分ですね。


SetCursorについて   石男
email:  Thu Jan 20 18:46:01 2005

SetCursorの引数に自作のカーソルIDを渡してみたところ、やはり駄目でした。
SetCursorの引数自体はリソースIDのようですが、決まったところにあるリソースを参
照している感じです。でもそのリソースが見つかりませんでした...。VW本体をResEdit
で開いたところカーソルリソースは存在するのですが、IDが違いました。
他のリソースらしきものを調べてみましたが、カーソルリソース自体がありませんでし
た。以上、念のため...。


基点コピー&ペースト&移動   与太郎
email:  Tue Jan 18 22:32:00 2005

AutoCAD風に基点コピー&ペースト&移動をするスクリプトです。

procedure BCopy;
{ 基点コピー }
const
tempFile = 'BCopy.temp';
var
x, y:real;
begin
Message('コピーの基点をクリックしてください。');
GetPt(x, y);
ReWrite(tempFile);
Writeln(x);
Writeln(y);
Close(tempFile);
DoMenuTextByName('Copy', 0);
ClrMessage;
end;
Run(BCopy);


procedure BPaste;
{ 基点ペースト }
const
tempFile = 'BCopy.temp';
var
x, y, xc, yc:real;
begin
UseDefaultFileErrorHandling(false);
Open(tempFile);
if GetLastFileErr <> 0 then begin
AlrtDialog('コピー基点が一度も設定されていません。');
end
else begin
Message('ペーストの基点をクリックしてください。');
GetPt(x, y);
Readln(xc);
Readln(yc);
Close(tempFile);
DoMenuTextByName('Paste In Place', 0);
MoveObjs(x-xc, y-yc, false, false);
ClrMessage;
end;
end;
Run(BPaste);


procedure BMove;
{ 基点移動 }
var
x1, y1, x2, y2:real;
begin
Message('移動の始点をクリックしてください。');
GetPt(x1, y1);
Message('終点をクリックしてください。');
GetPt(x2, y2);
MoveObjs(x2-x1, y2-y1, false, false);
ClrMessage;
end;
Run(BMove);

選択図形がないのにコピーしたり、クリップボードが空なのにペーストすると、エラーメッセージ
が出ますが、選択図形の有無はともかく、クリップボードの状態はスクリプトでは調べられません。


オートパン&ズーム   与太郎
email:  Fri Jan 7 18:54:37 2005

スクリプトを書いてみましたが、やはりパンカーソル&ショートカットキーのほうが早いです。
それに、画面上の図形が少ないときはスムーズに動きますが、図形が多いときはパンが遅くて、
図形が少ない部分で急に早くなるので使いにくい。(マシンが遅いのもあるでしょうが)

ところで、SetCursorで自分が作ったカーソルを使えるのでしょうか?
パンの方向によってカーソルが変わったほうが面白いので。
Winなので調べようがなかったのですが、SetCursorの引数はカーソルリソースIDのような気が
します。(Messageで表示すると、1307とか1308でした。)
一応リソースつながりということで。

procedure AutoPanZoom;
{ オートパン&ズーム }
{ クリックで200%ズーム、Option(Alt)キーを押しながらだと50%縮小。 }
{ Escで終了する。 }
{ VW9(デモ版)だとKeyDownで文字が返って来ない。 }
const
_Esc = 27;
_LF = Chr(13);
var
_fraction,display_:longint;
_format_:integer;
_upi_:real;
_name, squareName_:string;
_scale_:real;
_zm, diagonal_:real;
_x1, y1, x2, y2, wd, ht_:integer;
_x, y, xc, yc, dx, dy, d_:real;
_ch_:_integer;
_k_:real;
_dmy_:boolean;

procedure Pan;
begin
_zm:= GetZoom;
_GetMouse(x, y);
_GetVCenter(xc, yc);
_k:= 2 * (Distance(x, y, xc, yc)/(100*diagonal/zm))^1.5;
_dx:= x - xc; dy:= y - yc;
_d:= Abs(dx);
_if d < Abs(dy) then
__d:= Abs(dy);
_d:= d * k;
_if (diagonal/Sqrt(wd*wd+ht*ht)) < d then begin
__SetVCenter(xc-dx*k, yc-dy*k);
__SetCursor(HandC);
__ReDrawAll;
_end{if}
_else begin
__SetCursor(LgCrossC);
_end;{else}
end;{Pan}

procedure Zoom(k:real);
begin
_zm:= GetZoom;
_GetVCenter(xc, yc);
_if k = 0 then begin
__if Option then
___k := 0.5
__else
___k:= 2;
_end;{if}
_zm:= zm * k;
_dx:= x - xc; dy:= y - yc;
_x:= x - dx/k; y:= y - dy/k;
_SetVCenter(x, y);
_SetZoom(zm);
_ReDrawAll;
end;{Zoom}

begin{main}
_Message('1,C:拡大/2,V:縮小/3:原寸/4:用紙全体/5:図形全体/Esc:終了');
_GetScreen(x1, y1, x2, y2);
_wd:= x2 - x1; ht:= y2 - y1;
_GetUnits(fraction,display, format, upi, name, squareName);
_scale:= GetLScale(ActLayer);
_diagonal:= Sqrt(wd*wd+ht*ht)/72*upi*scale;
_AlrtDialog(Concat('オートパン&ズーム', LF, 'Escで終了します。'));
_dmy:= KeyDown(ch);
_while ch <> Esc do begin
__case ch of
___Ord('1'), Ord('c'), Ord('C'): Zoom(2);
___Ord('2'), Ord('v'), Ord('V'): Zoom(0.5);
___Ord('3'): begin DoMenuTextByName('Normal Scale', 0); ReDrawAll; end;
___Ord('4'): begin DoMenuTextByName('Fit to Window', 0); ReDrawAll; end;
___Ord('5'): begin DoMenuTextByName('Fit To Objects', 0); ReDrawAll; end;
___otherwise begin
____if MouseDown(x, y) then
_____Zoom(0)
____else
_____Pan;
___end;{otherwise}
__end;{case}
__dmy:= KeyDown(ch);
_end;{while}
_ClrMessage;
end;{main}
Run(AutoPanZoom);


Re:ダイアログに画像   石男
email:  Thu Jan 6 9:52:20 2005

管理人さん、下の書き込み削除願います、きちんとまとめていませんでした。

//リソースファイルの作成
VectorScriptではMac形式のリソースファイルを使用します。このリソースファイルの
中に文字列(STR#)やピクトイメージ(PICT)といったリソースを格納します。
ダイアログに表示させたい画像がPICTです。
リソースファイルを作成するにはResEdit(Mac OS 9)もしくはResorcerer(OS X)が必要
です。
//リソースファイルの利用
リソースファイルは必ず「Plug-Ins」フォルダ内に保存してください。
この時、リソースファイルにはMacなら".rsrc"、Windows版の場合は".rsr"という拡
張子をつけます。なお、Winでリソースファイルを使う場合、A+Aサイトの開発室に
ResDresというプログラムがあります。これを使ってリソースファイルを加工してください。これでWinでも読めるリソースファイルになります。これを行わないと読め
ないはずです。以上が準備段階です。

//ソースコード内
SetVSResourceFile(fileName)を一度実行すると、スクリプトが終了するまでリソー
スファイルにアクセス出来ます。fileNameは拡張子を除いたファイル名です。
実際にリソースを呼び出すにはCreateControl()、SetControlData()を使用します。

文字列のリソースはVWでも作れるみたいですが、使い方がよくわかりません。
という訳でリソースを扱う場合、Macが必要です。


Re:ダイアログに画像  masafumi
email:  Wed Jan 5 22:41:17 2005

以前(2001/09)メーリングリストで教えて頂いた事が有ります。
その時は、Macで作成したリソースファイルでしたら Windows版でも表示出来ました。
Windows版の場合、リソースファイルの拡張子は"***.rsr"とします。
このリソースファイルは Mac 専用のフォーマットでなければならないらしいです。
当時、私はリソースファイルを作成するために中古の iMac を購入しました。


Re:ダイアログに画像   マッハ
email:  Wed Jan 5 20:20:29 2005

与太郎さん、ありがとうございます。
詳しい説明の仕方がわからず、端的な質問しましたが、さすが与太郎さん
そうなんです、リソース部分で全く分からなくなっています。
よろしく、お願いいたします。


Re:ダイアログに画像   与太郎
email:  Wed Jan 5 19:51:06 2005

リソースファイルから画像を読み込んでモダンダイアログに表示出来ます。

if SetVSResourceFile(fileName) then begin
CreateControl(dialogID, itemID, controlKind, name, data);
end;{if}

fileName : リソースファイルのファイル名前
dialogID : ダイアログID
itemID : アイテムID
controlKind : コントロールの種類(1=画像/2=システムカラーパレット/3=スライダー)
name : コントロールの名前(何でも構いません)
data : コントロールのデータ(PICTリソースのリソースID)

SetVSResourceFileでリソースファイルを開いて、CreateControlで画像をセットします。
Macなら、ResEditでリソースファイルを作れるのですが、Winでリソースファイルを作る
方法が判りません。MacのファイルをWinで読んでも、リソース部分は無視されると思い
ます。そもそも、SetVSResourceFileがWin版で有効かどうかも知りません。(^^;)
ご存知の方、宜しくおねがいします。


ダイアログに画像   マッハ
email:  Wed Jan 5 17:05:02 2005

ダイアログに画像を入れることは可能でしょうか。(windows)


パス図形に沿って文字を配列する スクリプトのバグ   与太郎
email:  Tue Jan 4 19:12:07 2005

均等配列文字のスクリプトを書き終えて、休み前には燃え尽きてしまいましたが、
休み中に、縮尺/単位が異なるファイルで試したら、バグが発覚してしまいました。
211行目の if (0 < i) & (i < (lng-1)) then begin が、
if (0 < i) & (i < (numText-1)) then begin の間違いです。


Re:初心者です。   与太郎
email:  Tue Jan 4 18:11:27 2005

ACTさん、
VectorWorks 談話室のほうにレスしました。


初心者です。  ACT
email:
hirosi@jmail.plala.or.jp  Mon Jan 3 23:17:41 2005

どうもドラフターの感覚が抜けません。
ダブルラインではなくて、平行線はどう書きますか。


バックナンバー   管理人
email:
manager@vwch.infonav.net  Tue Dec 28 14:04:12 2004

バックナンバーもご利用下さい。
本当は使いやす整理すべきなのですが…


大盛況につき   管理人
email:
manager@vwch.infonav.net  Tue Dec 28 14:02:51 2004

皆さんのおかげでScript談話室がおおいに盛り上がりました。
大盛況につきメンテナンスです。