Egg's Blog

●RPC

RPCのコンテンツ購入はこちらから　3D RPC

プラグインとなるツールは開発元にてarchvision.com

ユーザー登録してツールをセットアップ
こちらを参照に！

●レンダリング　露出の調整　1

レンダリング　露出の調整について　その 1

左のレンダリングは逆光のため影の部分が暗くなってしまう。
このような時は露出を補正する。

パネル内のレンダリングから「露出の調整」：RENDEREXPOSURE で明るさ、コントラスト、中間トーンを変更する
例
規定値　明るさ：65　コントラスト：50
右は　　 明るさ：75　コントラスト：50

後はセンス！

露出を調整すると
パネル内の「光源」　明るさ、コントラスト、中間トーンとリンクしている。

モデル空間で、複数のビューポートを表示している場合リンクしない
モデル空間の場合は１つのビューポートで調整すること。

レイアウトからビューポート内で調整すると良く、
ビューポートごとに露出調整も保存される。

出力サイズの比率と同じビューポートサイズで作成すると
出力範囲も限定できる。（セーフフレームの役目にもなる）
ビューポートはチェック用として
出力先はビューポートでは無く、レンダリングウィンドウへ!!

●太陽の位置　北方向の変更

太陽位置は「地理的位置」_geographiclocation　で設定

北方向の向きは角度で変更することができる

0度と180度を比べてみると！

太陽のサイズを変更するには
「日照と上空の背景を調整」
「日照プロパティ」からと「ビュー管理」からアクセスできます。

●レンダリング背景 Imageとの位置合わせ

AutoCADで写真を背景にレンダリングする場合
まず、Imageデータのサイズを確認！
例 960x1280

Imageの比率に合わせレイアウトにビューポートを作成
用紙サイズはA4、3程度でビューポートサイズは 96x128
（ビューポートサイズを入力する時は「@」を忘れずに！）

ビューポート内で「ビュー管理」から予め作成したカメラやビューを呼び出す。
再度「ビュー管理」から新規作成 or 既存のビューから

表示スタイル：リアリスティク
背景：イメージ
　　　 （「イメージ調整」‐「イメージの位置」：ストレッチ）

背景に合わせオービットで位置を微調整。
微調整したビュー再度を登録し
（ビュー管理は「新規作成」から作成し同名で登録すると上書きできる）

レンダリングサイズをイメージに合わせ 960x1280
ビューポートからレンダリング！

●外部参照と注釈尺度

同一尺度で注釈の位置を変更する。

資料：PDFファイル

注釈尺度はスタイルのようなもの！
名前を変え作図単位を同じにすれば同一尺度でも位置変更はできます。

●LIGHTINGUNITS

AutoCAD 2008 Helpより
システム変数：LIGHTINGUNITS

タイプ: 整数型
保存先: 図面

一般光源を使用するか測光光源を使用するかをコントロールするとともに、現在の光源ユニットを示します
このシステム変数が 1 または 2 のときは、フォトメトリック照明が有効です。0(ゼロ)の時は標準(一般)照明が使用されます。

0： 照明単位は使用されず、標準(一般)照明が有効になります。

1： 国際照明単位が使用され、フォトメトリック照明が有効になります。

2： 米国の照明単位が使用され、フォトメトリック照明が有効になります。

Helpにもありますが、この変数で「上空の背景とイルミネーション」利用の可否が決まります。
0：

1,2：

旧図面を開いた時に０となっているので注意しましょう。

●カメラ

カメラビューの作成手順

１、作業しやすいように予めビューポートを分割しておきます。
「表示」－「ビューポート」-「ビューポート管理」
「新規ビューポート」タブ 「3分割：左」を選択「OK」

その他「ダッシュボード」「プロパティ」を表示、「OSNAP」をOFFにしておきます。

２、カメラの作成
ダッシュボードから「カメラ作成」
P1、P2をクリック　「Enter」

作成されたカメラを選択
「カメラプレビュー」が表示されます。
（カメラプレビューが表示されない時は右クリック「カメラのプレビューを表示」）

３、カメラの編集
カメラを選択しプロパティから
「カメラ長（mm）」：35（レンズサイズを入力）
「カメラ Z」：1600（目の高さ）
「目標 Z」：9000（目線の高さ）

カメラのプレビューを見ながら
カメラ位置をグリップで調整
「Esc」で終了

４、ビューを確認
右上ビューに移り
「3D ナビゲート」から「ビューを管理」を選択

「カメラ１」を選択
表示スタイル：「リアリステッィク」
背景の優先：「日照と上空」...
　　　[日照と上空の背景を調整]が表示され
　　　上空プロパティ　「状態」：「上空の背景とイルミネーション」　（2008New）
　　　「OK」
「OK」

「3D ナビゲート」から「カメラ１」を選択

微調整はカメラ１の位置、プロパティを編集しましょう。
カメラで設定した後オービットで編集した場合は
カメラにプロパティは適用されず、別ビューとなります。
この場合はビュー管理で保存しておくことが必要になります。
3D オービットでの編集はしないようにカメラにプロパティを残すことをお勧めします。

練習用...
サンプルDWG

●AutoCAD LT 2008 カスタムメニュー

CEC生徒さんへ

AutoCAD LT 2008 用のカスタムメニュー

「Version 2008 カスタマイズ 資料」[メニューCUI ファイルの位置]を参考に
ファイルを上書きしてください。

現在のaclt.cuiのバックアップは必ず取っておきましょう。

ワークスペースは「Work」に設定します。

●AutoCAD 2008 カスタムメニュー

CEC生徒さんへ

AutoCAD 2008 用のカスタムメニュー（LTでは利用できません。また、Japaneseのみです。）

「Version 2008 カスタマイズ 資料」[メニューCUI ファイルの位置]を参考に
ファイルを上書きしてください。

現在のacad.cuiのバックアップは必ず取っておきましょう。

ワークスペースは「Work」に設定します。

●Version 2008 カスタマイズ 資料

AutoCAD＆AutoCAD LT 2008バージョンでのカスタマイズ資料
　・CUI
　・ツールパレット
　・Diesel
　・線種
　・ハッチング

●Version 2007 カスタマイズ 資料

AutoCAD＆AutoCAD LT 2007バージョンでのカスタマイズ資料
　・CUI
　・ツールパレット
　・Diesel
　・線種
　・ハッチング

●LT DIESEL Sample

DIESEL(Direct Interpretively Evaluated String Expression Language)

LTで利用できるマクロ例として
面積計算　と　連番文字記入のサンプルを掲載

パレットにしてあります。

サンプルDWG

サンプルパレット

１、マクロの中でシステム変数を得る：$M=$(GETVAR,ｼｽﾃﾑ変数)

２、『SETENV　＆　GETENV』
　　SETENV;変数名;\
　　\の時に値を入力します

　　この値を得る時は
　　$M=$(GETENV,変数名)

サンプルではこの作業の繰返しで
Dieselで利用できる関数を使いコマンドを羅列しています。
コマンドの作業手順を決め色々なコマンドを組合わせ作成してみましょう。

LT Help（F1）‐カスタマイズ ガイド-DIESEL 式-DIESEL 関数カタログ
+ (加算)
- (減算)
* (乗算)
/ (除算)
= (に等しい)
< (より小さい)
> (より大きい)
!= (に等しくない)
<= (より小さいか等しい)
>= (より大きいか等しい)
and
angtos
edtime
eq
eval
fix
getenv
getvar
if
index
nth
or
rtos
strlen
substr
upper
xor

●Layer コンボボックス

画層フィルタ コンボ コントロール

フィルタが画面で確認でき作業に合わせ切替えができる。
フィルタ反転がチェックで切替えができ 外部参照以外のレイヤー表示が楽になった。

（フィルタは作図作業で不必要な画層の表示を非表示にする時に利用する機能）

画層状態コンボ コントロール

作業ごとのレイヤー設定が楽に切替えできる。
私は面積情報をハッチングで管理してるため
ON／OFF切替えが楽になった。

ダッシュボードのみに追加された機能だが（セットアップ後 表示される右側のパネル）
ダッシュボードが少々使いづらい。
必要なものだけ表示してCUIコマンドでパネルをカスタマイズしている。

こんな画面で利用しています。

●ExportLayout 2

ExportLayout 利用について 2

変換する前のチェック事項

１、文字スタイルの文字高さ「０」

２、異尺度対応のブロック図形
　　変換後サイズ変更がされないため
　　これには追加尺度で「１：１」の尺度を予め追加しておくこと

変換後別のCADへデータを渡す場合
「SXF データトランスレータ」を使い変換するとスムーズにコンバートできる。
　　

●オブジェクト選択オプション

「オブジェクト選択：」
このときキーボード入力で以下のオプションが利用できる。

[窓(W)]/[最後(L)]/[交差(C)]/ボックス(BOX)/すべて(ALL)/[フェンス(F)]/[ポリゴン窓(WP)]/[ポリゴン交差(CP)]/[グループ(G)]/[追加モード(A)]/[除外(R)]/[一括モード(M)]/[直前(P)]/[元に戻す(U)]/自動モード(AU)/単一モード(SI)/サブオブジェクト(SU)/[オブジェクト(O)]

組合わせて利用すると
オブジェクト選択ムービー

ツールパレット Select.xtpファイル
（右クリックして「対象をファイルへ保存」）

ダウンロードしたファイルを読込むには
こちらを参照
ツールパレットの読込み

●外部参照

外部参照の更新通知

参照ファイルを更新して無いのに表示が出てしまう。

再ロードしても...　マークはそのまま...

ファイルフォーマットが違うと起こる問題だそうで、、、
参照ファイルのフォーマットを更新したら表示は改善されました。

プロジェクト内でバージョンが異なる時は、、、
　　　　　　あきらめるしかない？／　表示は気にしない。
　　　　　　キチント直してね！deskさん

●ExportLayout

AutoCAD 2008 / AutoCAD LT2008 で利用できる
レイアウト - モデル変換ツール(プレビュー版)

他CADを利用する協力会社へのデータ送付にはトーッテモ便利です。
（できればスクリプトで処理できるようダイアログが出ないようにスイッチを付けてほしいです。）

私の利用範囲で問題はなかったのですが、
生徒さんからの図面で変換時に不具合があったのでご報告

文字スタイル 「文字の高さ」を「０」以外にしておくと
変換時に寸法の文字高さが固定されてしまいます。

あたり前の結果でプログラムには問題はありません。
普段の利用時でもそうですが、文字スタイルの文字高さは「０」にしておきましょう。
文字高さは「TextSize」で変更しましょう。
（CEC Textにも書いてあります。）

その他：既知の問題

配布後これといってWebに問題はあがってないようですが、
サポートの対象で無いのであればなお更
今後のスケジュールや、以後の問題点などユーザーが解るように
オープンにしてほしいですね。

●LAYEREVAL&LAYERNOTIFY

memo:
LAYEREVAL：Layer eval
eval -> evaluation:評価
LAYEREVAL：レイヤー評価

LAYERNOTIFY：Layer notify
notify:通知
LAYERNOTIFY：レイヤー通知

LAYEREVAL
タイプ: 整数型
保存先: 図面
初期値: 1

0：表示しません。
1：新規外部参照画層が図面に追加されたことを検出します。
2：新規画層が図面または外部参照に追加されたことを検出します。

LAYERNOTIFY
タイプ: ビットコード
保存先: 図面
初期値: 15

0：表示しません。
1：印刷するとき。
2：図面を開いたとき。
4：外部参照のロード/再ロード/アタッチのとき。
8：画層状態を復元するとき。
16：図面を保存するとき。
32：ブロックを挿入するとき。

(「AutoCAD2008 コマンド リファレンス」より)
詳細は「Help：新しい画層の通知を使用する」

●Mouse

只今 実施設計 真最中！
（最近まーったく行けてません...（muraさんへ））

突然 マウスが壊れ 新規購入

今までWindowsになってからずーっと3つボタン
遅ればせながら5ボタンに初挑戦！

G3 Laser Mouse

設定はカンタンで
附属ソフトで各ボタンにショートカットを割当てるだけ

「Enter」「Cancel」「Ctrl+Z」の3つを割当てた。
（私は左ききなので、右ききの人は「Enter」「Cancel」は反対かな？）

とても使い勝手が良く
R10のころのオペレーションを思い出しました。

●「ツールパレット」のススメ　３

XTPファイルの書出し。

作成したパレットを他のPCに移植、ユーザーに配布する。
○○○.XTPファイルとパレットで利用しているイメージデータがXTPファイルと同名のフォルダで書出される。

これを配布し、読込み作業を行う。
読込んだ後はこのファイルとフォルダは必要なくなり
パレットの内容はユーザーのパレットパス内に保存される。

作業手順
１、「ツール」－「パレット」－「ツールパレット」
　　表示されたツールパレット上で右クリック「パレットをカスタマイズ」
　　

２、書出すパレットを選択し右クリック「書き出し」
　　

３、書出すフォルダを選択し 「保存」

●「ツールパレット」のススメ　２

XTPファイルをロードする。
2Dツールをまとめたサンプルです。

ダウンロードファイル　「ToolPalette.zip」

１、「ツール」－「パレット」－「ツールパレット」
　　表示されたツールパレット上で右クリック「パレットをカスタマイズ」
　　

２、「パレット」内で右クリック「読込み」
　　「2D Work.xtp」ファイルを選択し開く
　　

　　「閉じる」で完成！

●塗潰しハッチングを利用して背後の図形を非表示

図のようにタグ部分の背景を非表示にして印刷したい場合
（AutoCAD＆AutoCAD LT）

　タグに塗潰しハッチングをし、最前面に配置

　このままだと印刷時にタグ部分は真っ黒
　印刷スタイルでハッチングで利用した色を白にして印刷。

手順

１、タグブロックにハッチングを追加

ハッチング用の特定レイヤーを作成
例）レイヤー名：i_Area-Hatch　色：250
（後から色変更が出来るようにハッチングは「ByLayer」で作成しておく）
ハッチングは最背面にする
（色は作業時の背景により黒なら250、白なら255が適当だろう。）

２、印刷スタイルの色設定
ページ設定管理から印刷スタイル（ペンの割当て）を編集

色：250　を選択し「色」から「色選択..」
「True Color」から 254,254,254　を設定
（ここで白にしてしまうと印刷時黒くなるので、限りなく白に近い色を作成）
これを印刷時の印刷スタイルとして利用する。
できれば、「名前を付けて保存」から別名にして
保存しておこう。

備考
「iArea2005」を利用されている方は添付「Sample.dwg」を参照して下さい。

●AutoCAD建築床面積表 「iArea2005」 update! Ver1.1

建築床面積表プログラムを更新しました。

更新内容：
１、タグ番号に接頭文字を追加
２、１、に伴い表のソート方法を変更
３、レイヤーを個別に現在層を利用できる
４、新規ファイルに対し前回の設定を利用
　　（レイヤー名は保存されません。）
・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・

注）アップデートユーザーは、ＩＤ・パスワードを控え
現在セットアップされているデータをコントロールパネルより削除
新規にセットアップして下さい。
セットアップ方法は添付のReadme.txtを参照してください。

Download：i_Area2005.zip

●AutoCAD Modify Tools2

寸法線を選択、トータル距離を入力しストレッチ

右クリックで「再生」

Command :ANDIMSTRETCH

交差選択し、変更する側の寸法線分を選択
（補助線、文字ではいけません。）
トータル距離を入力し「Enter」
選択位置の反対側からの距離を計算しストレッチします。

ダウンロードファイル（anModify.fas）
　
ボタンへの登録は
$M=$(if,$(eq,$(substr,$(getvar,cmdnames),1,4),GRIP),_andimStretch,^C^C_andimStretch)

●AutoCAD Modify Tools

Offset Toolに加え
編集ツールを２つ追加しました。

（AutoCAD）

マクロ名　１、anwOffset
　　　　　　　　二重線を作成します。

　　　　　　２、ansOffset
　　　　　　　　オフセットした線分のコーナーを連結します。

　　　　　　３、ansMirror
　　　　　　　　線分選択でMirror。
　　　　　　　　ansMirrTextで基図形の削除設定

　　　　　　４、ansMidLine
　　　　　　　　２線分選択で中心線を作図。

ダウンロードファイル　（anModify.dvb）

マクロの登録方法はこちら

●VBAからVB .netへ

as さんの　「VB2005用ActiveXテンプレート」を利用させて戴いて
　
「Visual Basic 2005 Express Edition」でAutoCAD2006をカスタマイズ！
　
移行はとーってもカンタンだ

VBAで作成したコードをそのままコピー
「Thisdrawing」を「doc」に置き換え
（Dim doc As AcadDocument = Loader.AcadApp.ActiveDocument）

の部分を消すと

自動で選択群が出てきて 選ぶだけ

　
エディタは使いやすい。

サンプルは
ペーパー空間で浮動モデルの画面移動
レイアウトの位置合わせをする時に利用している。
（ビューはロックされる）
　
「サンプルdll」
（サポートパスが通っているフォルダへ配置）
コマンド：netload [AutoCAD 2006 ActiveX Test1.dll]を選択
コマンド「an_ppan」
　
「サンプルコード」
　
asさんに感謝！

「NetLoad」についてはmuraさんのこちらを参照

●「ツールパレット」のススメ　１

Ver2004から登場したツールパレット（Ctrl＋3）
　
ハッチングとブロック図形のみの登録だったが
Ver2005からコマンドも登録でき使いやすくなった。
　
利点はカスタマイズがカンタン（CUIは表示がオソーイ）
配布もフォルダコピーでらくらく？
　

こんな感じで使ってます。
Ver2006

　
アイコンのプロパティは（アイコンで右クリック－プロパティ）
レイヤー指定などができレイヤー変更しなくてもカッテに変わる。
（図面上の図形をパレットへドラッグすれば登録できる）

また、ブロック図形では図面尺度に応じて
配置する時の尺度が変更できる
（尺度は寸法尺度と印刷尺度から参照。）
　
ツールバーからの移行のしかた
パレット上で右クリック　－　「カスタマイズ」を選択
　
カスタマイズ画面を表示したままの状態で
各ツールバーからボタンをドラッグすれば作成完了！
（フライアウトの表示を変更するには
作成後　プロパティ から 「フライアウトを使用」を「いいえ」に変更）
　
同じアイコンを複数作成（レイヤー変更のみなど）したい時は
パレットのアイコンを右クリックでコピー－ペーストすればOK
（「Ctrl」を押したままドラッグも可）
　
おまけ
Ver2007ではパレットからCUIへドラッグできる。

●Offset Tool 2

オフセットツールの更新

更新内容
　　　　　　　１、UCSに対応
　　　　　　　２、ネストした図形に対応
　　　　　　　　　（Line図形だけですけど...）

●コマンドラインでオプションの表示

Getpoint メソッドを利用して
座標 または　オプション文字を取得するには

InitializeUserInput メソッドで キーワードを作成
GetInput メソッドで入力された文字を取得します。

参考：AutoCADHelp　ActiveX/VBA 開発者用ガイド
「GetInput メソッド, GetInteger メソッドと使用」

'///////////////////////////////////////////////////////////////////////

Sub pointTest()

Dim pntA As Variant
Dim tempPnt(2) As Double
Dim initStr As String
Dim keyStr As String
Dim promptStr As String

    '点の定義
    tempPnt(0) = 10#: tempPnt(1) = 10#: tempPnt(2) = 10#

    'InitializeUserInputのキーワード
    keyStr = "U C"
   
    'コマンドプロンプト
    promptStr = "next point [元に戻す(U)/閉じる(C)]: "
   
    '点の取得
    pntA = anGetPnt(initStr, tempPnt, keyStr, promptStr)
   
    If IsEmpty(pntA) Then
        MsgBox initStr
    Else
        MsgBox pntA(0) & "," & pntA(1) & "," & pntA(2)
    End If
   
End Sub

'-----------------------------------------------------------

Function anGetPnt(ByRef gWord As String, beforPnt As Variant, keyWordStr As String, mesageStr As String) As Variant

On Error Resume Next

    'InitializeUserInput
    ThisDrawing.Utility.InitializeUserInput 2, keyWordStr
   
    '参照点の判別
    If IsEmpty(beforPnt) Then
    anGetPnt = ThisDrawing.Utility.GetPoint(, mesageStr)
    Else
    anGetPnt = ThisDrawing.Utility.GetPoint(beforPnt, mesageStr)
    End If
   
    If Err Then
        Select Case Err.Number
        Case -2147352567  'Esc
            gWord = "Esc"
           
        Case -2145320928  ' Put Keyboard
            '文字の取得
            gWord = ThisDrawing.Utility.GetInput
            If gWord = "" Then
                gWord = "Enter"
            End If
           
        Case Else
        End Select
        Err.Clear
    End If
End Function

●Offset Tool

今年最初は
オフセットツールのご紹介
（どこにでもあるようなものですが、、、）

ダウンロードファイル　（an_Woffset.dvb、an_Woffset.ini）

VBAで作成してあります。（test Ver2006）

マクロ名　１、anwOffset
　　　　　　　　二重線を作成します。

　　　　　　２、ansOffset
　　　　　　　　オフセットした線分のコーナーを連結します。

登録方法はこちら
　　　　

●VBAをコマンド登録 & メニュー作成

作成したVBA（dvb）をコマンドとして実行できるように登録

マクロ内に
^c^c(vl-vbarun "dvbファイル名!マクロ名")
という方法がある

ここでは少々面倒だがあえて
メニューを作成しコマンドとして登録してみる。

１、VBAファイル（SampleProject.dvb）をフォルダに保存
（例、d:\acCustom）

２、AutoCADからパスを通しておく
ファイルを相対的に利用できるようにする為です。
「ツール」-「オプション」　「ファイル」タブ
「サポートファイルの検索パス」を選択
「追加」をクリック、「参照」をクリック フォルダを選択します。

３、メニューの作成
部分CUIファイルを作成：「accustom.cui」
ツールバー　：「MyTools」
名前　　　　　：「Sampleコマンド」
コマンド　　　：「csample」
アイコン　　　：「csample.BMP」として登録

「ツール」-「メニュー」-「インターフェイス」

注）コマンドを新規作成した時は「acad」メニューに作成されます。
この後、別のメニューにドラッグすると ２つのコマンドが作成されてしまいます。
「acad」メニューにできたコマンドは削除しておきましょう。

４、mnlファイルの作成
コマンドとして利用できるようにLispで登録
mnlはこのメニューがロードされた時に自動的に読込まれるファイル。

メモ帳で
mnlファイルを作成：「accustom.mnl」

dvbファイル

●Text Link!

外部参照内の文字のリンク
ダウンロードファイル

サポートフォルダ内にファイルを配置します。
ファイルをロード後、コマンド：「cec_textlinkat」
外部参照したデータ内の文字を選択、文字が配置されます。
文字高さはTextSizeから取得しています。

更新時には　コマンド：「(cec_textlinkup)」
リンクされた文字が更新されます。

基の文字が見つからない場合は
更新時に文字が赤く表示されます。

●entmakeで寸法線

ちょこっとmemo : entmakeで寸法線

;Acad Ver 2006
(entmake (list '(0 . "DIMENSION")
        '(100 . "AcDbEntity")
;;;        '(8 . "0") ;Layer
        '(100 . "AcDbDimension")
        '(10 300.0 70.0 0.0) ;3rd
        '(70 . 32) ;Type
;;;        '(3 . "ISO-25") ;DimStyle
        '(100 . "AcDbAlignedDimension")
        '(13 100.0 100.0 0.0) ;1st
        '(14 300.0 100.0 0.0) ;2nd
;;;        '(50 . 0.0) ;Hor Ver Angle
        '(100 . "AcDbRotatedDimension")
        ))

●ExcelからDWG検索

幾つかのDWGファイルを繰返し作業する時
リストを作成しておくと便利！

下記は、Microsoftのサンプルのからコピーしたものです。
（Excel2002移行）

Excel　VBAの参照設定に
「Microsoft Scripting Runtime」を追加

Excel VBAへここから貼付け
____________________________________
Option Explicit
Option Compare Text

Function GetFiles(strPath As String, dctDict As Scripting.Dictionary, Optional blnRecursive As Boolean) As Boolean

' このプロシージャは、ディレクトリ内のすべてのファイルを
' Dictionary オブジェクトに返します。再帰的に呼び出
' される場合は、サブフォルダ内のファイルもすべて返します。

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

' 新しい FileSystemObject を返します。
Set fsoSysObj = New Scripting.FileSystemObject

On Error Resume Next
' フォルダを取得します。
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' パスが間違っています。
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
'**************************************************************************
Dim sDwg
sDwg = ".dwg"
Dim rightName

On Error Resume Next
' Files コレクションをループし、Dictionary に追加します。
For Each filFile In fdrFolder.Files

rightName = Right(filFile, 4)
If rightName = ".dwg" Then
dctDict.Add filFile.Path, filFile.Path
'dctDict.Add filFile.Name, filFile.Name

End If
Next filFile
'**************************************************************************
' 再帰フラグが真の場合、再帰的に呼び出します。
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If

' エラーが発生しなかった場合は、True を返します。
GetFiles = True

GetFiles_End:
Exit Function
End Function
' __________________________________________________________________________________
Sub DWGファイル検索()

On Error Resume Next

Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")

Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strDirPath As String

Dim dwgFile As String 'ファイル名
Dim pathDwg As String '検索フォルダの場所
Dim i As Integer 'カウント
' ファイル ダイアログを開きます。
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = True
.Show

Dim foName As String
foName = .SelectedItems(1)

End With

'******************************************

strDirPath = foName & "\"
' 新規 Dictionary を作成します。
Set dctDict = New Scripting.Dictionary
' 再帰的に呼び出し、Dictionary オブジェクトにファイルを返します。
If GetFiles(strDirPath, dctDict, True) Then
' Dictionary 内の項目を出力します。

Dim enCount
i = 2

For Each varItem In dctDict

Cells(i, 1).Value = varItem

Set f = fs.GetFile(varItem)

enCount = InStrRev(varItem, "\") + 1

Cells(i, 2).Value = Mid(varItem, enCount)
Cells(i, 3).Value = f.DateLastModified

i = i + 1
Next

Cells(1, 1).Value = strDirPath
Cells(1, 1).Font.Bold = True
Cells(1, 2).Value = dctDict.Count & " Files"
Cells(1, 2).Font.Bold = True

Columns("A:C").EntireColumn.AutoFit
Cells(1, 2).Select
End If

End Sub
__________________________________________________________________________________

●ダイナミックブロック チェーンアクション

SD建具のサンプルダイナミックブロック

Download file

作業用として「幅」を利用
「ドアW」＆「有効幅」を関連して変更させる。
こんな時はチェーンアクション！

「ドアW」＆「有効幅」グリップ数　：　「0」
チェーンアクション　：　「はい」

「ドアW」：ドア部分の幅
　　「尺度変更」アクションを適用
　　（ドア部分をストレッチアクション（角度オフセット：90）にすると
　　反転アクション時にチェーンアクションが効き、おかしな動きをする）
　　「プロパティ表示」を「いいえ」 画面に表示されないプロパティとなる

「有効幅」：SD開口の有効幅
　　値を取得のみに利用
　　建具表などと関連付けし利用する
　　（アクションに計算式を割当られないのが残念！）
　　「プロパティ表示」は「はい」 直接値は変更しないが、プロパティで確認できる。

●ダイナミックブロック &フィールド

ダイナミックブロック に フィールドを追加！

Download file

ブロックエディタ内で 属性文字を追加
右クリックし「フィールドを挿入」
「フィールド名」：
「ブロックのプレースフォルダ」からパラメータのプロパティを選択

配置しサイズを変更すると文字も更新される。

●ダイナミックブロック　ルックアップテーブル

ルックアップテーブル：
各パラメータの値を予め決めておき、名前を付け登録できる。
＿＿＿＿＿＿＿＿＿＿＿＿

これに値を追加、編集すると

自動で「読込み専用」となる。

このまま「OK」を押すと画面にルックアップは表示されないので注意！

変更後は「逆ルックアップを許可」に変更しておこう。

（サンプルとして、ツールパレット内の「六角ナット」などに適用されている）

●AutoCAD建築床面積表 「iArea2005」

建築床面積表プログラム
形状を指定し計測、面積表を作成　番号、計算式を記入
変更時には編集ツールを利用し再計測　表も更新されます。
その他Excel書出しなど追加

Download Page

デモ版からようやくシェア化
2006用は更に機能を追加する予定です。

●シートセット・マネージャ 2006

Acad2006のシートセット新機能

1. 既存図面（シート）の一括取り込み
   　　　・設定後　レイアウトシートの追加読込みができる
   
2.  シートのタイトルに合わせファイル名を変更
   
3. 新規サブセット名とフォルダ名を同一にする
   
4. 「ビュー一覧」でカテゴリ（分類）とシート別に表示切替
   
5. 利用状況によってアイコン表示が切替る
   　　・ ファイルが開かれている時ロック表示される
   　　・ ファイル名の変更、移動をした時「？」表示
   
6. シート一覧から複数ファイルを同時オープン
   　　・ 複数シートを選択し右クリック
   　　・ 「読み取り専用」にもできる

2006シートセットに関連する新機能

1. 尺度リストの編集
   　　オプション-基本設定　「尺度リストを編集」（scalelistedit）
   
2. DYブロック
   　　吹出しブロックの簡素化
   　　
   

Sample 吹出し用 ダイナミックブロック Download 　　


3. e-トランスミットの設定を外部から読込める
   　　e-トランスミット 「転送セットアップ」に「読込み」が追加された
   

●ExcelからAutoCADの操作

Excel VBAからAutoCADのライブラリを参照する

VBEditerで [ツール]－[参照設定]
AutoCAD 2006 Type Library ライブラリにチェック

'AutoCAD起動用関数________________________________

Public AcadApp As AcadApplication

Function acad_int()
On Error Resume Next

Set AcadApp = GetObject(, "AutoCAD.Application.16")'AutoCADヴァージョン

If Err Then
    Set AcadApp = CreateObject("AutoCAD.Application.16")
    AcadApp.Visible = True
End If

AcadApp.Visible = True

End Function

'現在の図面 又は 新規図面 ______________________________

Sub toAutoCAD()
On Error Resume Next

acad_int 'AutoCADの起動

Dim AcadDoc As AcadDocument

Set AcadDoc = AcadApp.ActiveDocument '現在アクティブな図面

If AcadDoc Is Nothing Then
    Set AcadDoc = AcadApp.Documents.Add("acadiso.dwt") '新規図面
End If

'以降 AutoCAD VBA 時の「Thisdrawing」 の代わりに「AcadDoc」を適用
'.
'.
'.処理後はメモリーリリース
    Set AcadDoc = Nothing
    Set AcadApp = Nothing
End Sub

●Excelへの書出し

Excelのライブラリを参照する

VBEditerで [ツール]－[参照設定]

Excel Object ライブラリにチェック！

_________________________________________
プログラムのながれ
１、 Start Excel
２、図面から図形選択
３、属性など書出す情報の処理
４、 Excelファイルの保存
_________________________________________

動作条件として
ブロック名 "*_aTag" 属性文字があること
サンプル図面
_________________________________________

Sub Example_AttExcelOut()

' Start Excel
On Error Resume Next
  
Dim Excel As Object
Dim exBook As Workbook
Dim exSheet As Worksheet

Set Excel = GetObject(, "Excel.Application")
  
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
          
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
  
    On Error GoTo 0
  
    Excel.Visible = True
  
    Set exBook = Excel.Workbooks.Add
    Set exSheet = exBook.Sheets("Sheet1")

'図形選択 /////////////////////////////////////////////////
    Dim SSet As AcadSelectionSet
    Dim GroupCode(1) As Integer
    Dim DataValue(1) As Variant
    Dim acBlObj As AcadBlockReference 'ブロック図形
On Error Resume Next
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
 
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    '(2 . "*_aTag") ブロック名 , (0 . "INSERT") ブロック図形
    GroupCode(0) = 2
    DataValue(0) = "*_aTag"
    GroupCode(1) = 0
    DataValue(1) = "INSERT"
 
   SSet.Select acSelectionSetAll, , , GroupCode, DataValue
 
Dim ssCount As Integer
    ssCount = SSet.Count
  
    If ssCount = 0 Then
        MsgBox "書出すBlockがありません"
        Exit Sub 'プロシージャから抜ける
    End If
  
Dim attArray As Variant '属性のリスト
Dim blockHandle As String 'ブロック図形のハンドル番号
                          'Excelからアクセスする時に利用する番号
                          '（書出しのみであれば不要）
Dim rowNum As Integer
Dim colNum As Integer
    rowNum = 1 'Excel行番号
    colNum = 1 'Excel列番号

'選択したブロックの繰返し処理 +++++++++++++++++++++++++
For Each acBlObj In SSet
    If acBlObj.HasAttributes Then '属性を持っていたら
        attArray = acBlObj.GetAttributes '属性の取得
        blockHandle = acBlObj.Handle
      
        With exSheet.Cells(rowNum, colNum)
            .NumberFormatLocal = "@" '文字として書込み
            .Value = blockHandle
        End With
      
       For colNum = LBound(attArray) To UBound(attArray)
          exSheet.Cells(rowNum, colNum + 1).Value = attArray(colNum - 1).TextString
        Next
      
        rowNum = rowNum + 1
        colNum = 1
      
    End If '.HasAtt
Next
'++++++++++++++++++++++++++++++++++++++++++++++++++++++

'Excelファイルの保存
    Dim docName As String
    Dim acadFname As String
    Dim exFname As String
    Dim exSfname As String
  
    docName = ThisDrawing.FullName
        If docName = "" Then
            acadFname = ThisDrawing.Name
        Else
            acadFname = docName
        End If
  
    exFname = Left(acadFname, (Len(acadFname) - 4))

    Do ' wait until the user supplies a file name or cancels
        exSfname = Excel.GetSaveAsFilename(exFname, "Microsoft Excel Worksheet(*.xls), *.xls")
    Loop Until exSfname <> ""
  
    If exSfname <> "False" Then ' if they cancel, the file name is "False"
        exBook.SaveAs FileName:=exSfname
        'Error  1004-------------------------------------------------
        If Err.Number = 1004 Then
            Err.Clear
        End If
    End If
  
    Set exSheet = Nothing ' release memory
    Set exBook = Nothing
    Set Excel = Nothing

End Sub

●図形の選択3

選択Filterの適用

LISPを知っていればカンタンなことだが

知らないひとは

「コマンド：Filter」から条件をとりだす。

１、「選択フィルタ」のリストから

　　適用したい条件を選び、「リストに追加」

　　「適用」クリックし試してみる。

２、成功なら名前入力「名前を付けて保存」

３、エクスプローラで「filter.nfl」 ファイルを検索

　　メモ帳で開く

　　括弧”（ ）”の部分をコピー

(8 . "A-Anno-Note")
(0 . "*POLYLINE")

これをVBで配列に割当てる

    Dim GroupCode(0 to 1) As Integer
    Dim DataValue(0 to 1) As Variant
    GroupCode(0) = 8
    DataValue(0) =  "A-Anno-Note"
    GroupCode(1) = 0
    DataValue(1) =  "*POLYLINE"

____________________________________________

Sub Example_Select3()
'Filterの適用

    Dim SSet As AcadSelectionSet
    Dim GroupCode(4) As Integer
    Dim DataValue(4) As Variant
    Dim acadObj As AcadObject
   
 On Error Resume Next
 ' Delete the Selection Set if it Exists
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
   
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    'Setup Selection Set Filter
'(-4 . "<OR")(0 . "LINE")(0 . "*POLYLINE")(0 . "CIRCLE")(-4 . "OR>")

    GroupCode(0) = -4
    DataValue(0) = "<OR"
    GroupCode(1) = 0
    DataValue(1) = "LINE"
    GroupCode(2) = 0
    DataValue(2) = "*POLYLINE"
    GroupCode(3) = 0
    DataValue(3) = "CIRCLE"
    GroupCode(4) = -4
    DataValue(4) = "OR>"
   
   SSet.SelectOnScreen GroupCode, DataValue
  
For Each acadObj In SSet
    Debug.Print acadObj.ObjectName
Next

End Sub

●図形の選択2

図形選択の方法２

対話しながらの選択
____________________________________________

１、シングル選択

GetEntity メソッド
GetSubEntity メソッド

２、SelectOnScreen メソッド
　　「オブジェクト選択：」を表示

３、Select メソッド
     Getxxxメソッドで予め点を取り組合わせ利用
　　モード
　　acSelectionSetWindow
　　acSelectionSetCrossing
　　acSelectionSetPrevious
　　acSelectionSetLast
　　acSelectionSetAll

　　SelectByPolygon メソッド
　　モード
　　acSelectionSetFence
　　acSelectionSetWindowPolygon
　　acSelectionSetCrossingPolygon 

　　SelectAtPoint メソッド
____________________________________________

Sub Example_Select2()

    Dim SSet As AcadSelectionSet '選択Set 選択図形をほうりこむ箱
                                 '"SS1"は箱の名前（なんでも良い）
    Dim acadObj As AcadObject
   
 On Error Resume Next  'Errorがあっても次に進む
 ' Eorror処理 もし同じ選択Setがあったら削除
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
   
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    '選択Setを図面に追加
   
    SSet.SelectOnScreen
    '画面上で図形選択
  
For Each acadObj In SSet
    Debug.Print acadObj.ObjectName
Next

End Sub

●図形の選択1

図形選択の方法

図面全体（データベース）から
取得する方法と対話しながらの選択とがある。

モデル空間にある全ての図形にアクセスする
（データ量が多いと結構時間が掛かる）
__________________________________________

Sub Example_Select1()

Dim acMS As AcadModelSpace 'Model空間
Dim acadObj As AcadObject 'AutoCAD図形

Set acMS = ThisDrawing.ModelSpace
'ThisDrawing : 現在開いているアクティブなファイル

For Each acadObj In acMS

    'この中で色々な繰返し処理をさせる
    Debug.Print acadObj.ObjectName
   'イミディエイト・ウィンドウに表示される
Next

End Sub
__________________________________________

●ユーザー入力

「Utility」には
Getxxx なるメソッドが幾つかある。

「オブジェクト モデル 」から
Document-Utility（一番下）

メソッドの一覧からGetPoint メソッドをクリック
サンプル コードから
_____________________________________________________________
Dim returnPnt As Variant

' Return a point using a prompt
returnPnt = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
_____________________________________________________________
の部分をコピーし貼付け

同様にGetCorner メソッドサンプル コードから下記をコピー
_____________________________________________________________
returnPnt = ThisDrawing.Utility.GetCorner(basePnt, "Enter Other corner: ")
_____________________________________________________________

エディタに貼付け
下記に変更し試してみる。
-----------------------------------------------------
Sub Example_AddLine2()
' This example adds a line in model space
Dim returnPnt1 As Variant
Dim returnPnt2 As Variant

' Return a point using a prompt
returnPnt1 = ThisDrawing.Utility.GetPoint(, " 1点目を指定 : ")

returnPnt2 = ThisDrawing.Utility.GetCorner(returnPnt1, " 2点目を指定 : ")

Dim lineObj As AcadLine

' Create the line in model space
Set lineObj = ThisDrawing.ModelSpace.AddLine(returnPnt1, returnPnt2)

End Sub

●プロパティの変更

LINEのレイヤーを「A」に変更
注）レイヤーは予め作成しておきます

Set ......の次の行に追加
lineObj.Layer = "A"

ついでに ZoomAll を ZoomExtentsにも変更してみる

●ブレークポイントとローカルウィンドウ

コード ウィンドウの左のバーをクリックすると
ブレークポイントができる。
実