| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
お世話になります。divideを使用して楕円形にブロックを配列したいのですが、キレイに配列されません。ブロック自体が回転するので。このような場合は何か良い方法があるのでしょうか？
宜しくお願いします。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
楕円ですと、接線の垂線方向が楕円中心を通らないですね。
ブロックを回転させながら挿入しても、ご希望の配列にならないかと・・・
挿入後に１つずつ回転させるしかないのでは？
著作権者の許可を得ていないため削除
ご使用のバージョンが AutoCAD 2005(R版)の様ですので VBA で作ってみました
DIVIDE[ディバイダ]
または MEASURE[メジャー] でブロックを配置後にご利用下さい
Public Sub BlockRotationSet()
Dim BlockSset As AcadSelectionSet
Dim ent As AcadObject
Dim dx As Double
Dim dy As Double
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim InsPoint As Variant
Dim ReturnPnt As Variant
On Error GoTo SSErr:
Set BlockSset = ActiveDocument.SelectionSets.Add("BSS1")
On Error GoTo Err:
FilterType(0) = 0
FilterData(0) = "Insert"
BlockSset.SelectOnScreen FilterType, FilterData
ReturnPnt = ActiveDocument.Utility.GetPoint(, "中心点を指示: ")
For Each ent In BlockSset
If ent.EntityName = "AcDbBlockReference" Then
InsPoint = ent.InsertionPoint
dx = ReturnPnt(0) - InsPoint(0)
dy = ReturnPnt(1) - InsPoint(1)
If dx > 0 Then
ent.Rotation = Atn(dy / dx) - (2 * Atn(1))
ElseIf dx < 0 Then
ent.Rotation = Atn(dy / dx) + (2 * Atn(1))
ElseIf dx = 0 And dy >= 0 Then
ent.Rotation = 0
ElseIf dx = 0 And dy < 0 Then
ent.Rotation = 4 * Atn(1)
End If
End If
Next ent
ActiveDocument.SelectionSets.Item("BSS1").Delete
Exit Sub
Err:
Resume Next
SSErr:
ActiveDocument.SelectionSets.Item("BSS1").Delete
Set Sset = ActiveDocument.SelectionSets.Add("BSS1")
Resume Next
End Sub
|
訂正と機能を少し追加、動作確認用の簡単なサンプルデータを以下にアップしました。
http://homepage2.nifty.com/kamegai/autocad/BlockRotationSet_SampleData.dwg
長文で申し訳ありません。
Option Explicit
Public Sub BlockRotationSet()
'ブロックを指定した点の方向に回転
' (1) オブジェクトを選択
' (2) 中心点(回転方向)を指示
' (3) 向き(内外)を指示
' (4) 補正角を入力
Dim BlockSset As AcadSelectionSet
Dim ent As AcadObject
Dim BlockCount As Long '回転させたブロック数
Dim Pi As Double 'π
Dim dx As Double 'デルタＸ
Dim dy As Double 'デルタＹ
Dim dc As Double '回転角 = 内向(In)/外向(Out)＋補正角 [ラジアン]
Dim returnReal As Double '補正角 [度(D)/ラジアン(R)]
Dim PromptStr As String 'プロンプト文字列
Dim PromptStr2 As String 'プロンプト文字列
Dim kwordList As String 'キーワードリスト
Dim inputString As String '入力 キーワード
Dim returnString As String '入力 キーワード [内向(In)/外向(Out)]
Dim LastInputString As String '入力 キーワード [度(D)/ラジアン(R)]
Dim InsPoint As Variant 'ブロックの挿入点
Dim ReturnPnt As Variant '中心点
Dim FilterType(0 To 1) As Integer 'フィルター
Dim FilterData(0 To 1) As Variant 'フィルター
With ActiveDocument
On Error GoTo SSErr:
Set BlockSset = .SelectionSets.Add("BSS1")
On Error GoTo Err:
Pi = 4 * Atn(1)
FilterType(0) = 0: FilterData(0) = "Insert"
FilterType(1) = 2: FilterData(1) = "*"
BlockSset.SelectOnScreen FilterType, FilterData
If BlockSset.Count = 0 Then
.SelectionSets.Item("BSS1").Delete
ActiveDocument.SendCommand "オブジェクトがありません " & Chr(3)
End
End If
On Error Resume Next
kwordList = "@ X"
PromptStr = "中心点を指示または x,y 入力 [座標/直前(@)/終了(X)] 直前<@>: "
'中心点 (GetPoint)
Do
.Utility.InitializeUserInput 128, kwordList
Err.Clear
ReturnPnt = .Utility.GetPoint(, PromptStr)
If Err = -2145320928 Then
'ユーザ入力 キーワード
inputString = .Utility.GetInput
If inputString = "X" Then
.SelectionSets.Item("BSS1").Delete
End
ElseIf inputString = "O" Or inputString = "" Then
'直前(@) (なぜ "O" ？)
ReturnPnt = .GetVariable("LASTPOINT")
Exit Do
End If
ElseIf Err = -2147352567 Then
'オートメーション エラー (OSNAP or ESC)
DoEvents
ElseIf IsArray(ReturnPnt) Then
'点入力 (ユーザ @ 入力)
Exit Do
Else
.SelectionSets.Item("BSS1").Delete
End
End If
Loop
kwordList = "In Out X"
PromptStr = "向きを指示 [内向(In)/外向(Out)/終了(X)] 内向<In>: "
'向き (GetKeyword)
Do
.Utility.InitializeUserInput 128, kwordList
Err.Clear
returnString = .Utility.GetKeyword(PromptStr)
If Err = -2145320928 Then
'ユーザ入力 キーワード
If returnString = "X" Then
.SelectionSets.Item("BSS1").Delete
End
End If
ElseIf Err = -2147352567 Then
'オートメーション エラー (OSNAP or ESC)
'この直後の GetKeyword は１回スルーされる
DoEvents
Else
If returnString = "X" Then
.SelectionSets.Item("BSS1").Delete
End
ElseIf returnString = "In" Or returnString = "" Then
'内向(In)
dc = 0
Exit Do
ElseIf returnString = "Out" Then
'外向(Out)
dc = Pi
Exit Do
End If
End If
Loop
kwordList = "D R X"
PromptStr = "補正角を入力 [度(D)/ラジアン(R)/終了(X)] "
PromptStr2 = "度"
LastInputString = "D"
'補正角 (GetReal)
Do
.Utility.InitializeUserInput 128, kwordList
Err.Clear
returnReal = .Utility.GetReal(PromptStr & PromptStr2 & "<0>: ")
If Err = -2145320928 Then
'ユーザ入力 キーワード
inputString = .Utility.GetInput
LastInputString = inputString
If inputString = "X" Then
.SelectionSets.Item("BSS1").Delete
End
ElseIf returnReal = 0 And inputString = "" Then
If LastInputString = "D" Then
dc = dc + returnReal / 180 * Pi '度→ラジアン
Else
dc = dc + returnReal 'ラジアン
End If
Err.Clear
Exit Do
ElseIf inputString = "D" Then
PromptStr2 = "度"
ElseIf inputString = "R" Then
PromptStr2 = "ラジアン"
End If
ElseIf Err = -2147352567 Then
'オートメーション エラー (OSNAP or ESC)
'この直後の GetReal は１回スルーされる
DoEvents
Else
If LastInputString = "D" Then
dc = dc + returnReal / 180 * Pi '度→ラジアン
Else
dc = dc + returnReal 'ラジアン
End If
Exit Do
End If
Loop
BlockCount = 0
On Error GoTo Err:
For Each ent In BlockSset
If ent.EntityName = "AcDbBlockReference" And Not (.Blocks.Item(ent.Name).IsXRef) Then
'外部参照は除外（レイアウトは考慮しない）
If Not (.Layers.Item(ent.Layer).Lock) Then
'ロックレイヤは除外
BlockCount = BlockCount + 1
InsPoint = ent.InsertionPoint
dx = ReturnPnt(0) - InsPoint(0)
dy = ReturnPnt(1) - InsPoint(1)
If dx > 0 Then
ent.Rotation = Atn(dy / dx) - (Pi / 2) + dc
ElseIf dx < 0 Then
ent.Rotation = Atn(dy / dx) + (Pi / 2) + dc
ElseIf dx = 0 And dy >= 0 Then
ent.Rotation = 0 + dc
ElseIf dx = 0 And dy < 0 Then
ent.Rotation = Pi + dc
End If
End If
End If
Next ent
If BlockCount = 0 Then
ActiveDocument.SendCommand "回転できるブロックがありませんでした " & Chr(3)
Else
ActiveDocument.SendCommand CStr(BlockCount) & "個のブロックを回転しました " & Chr(3)
End If
.SelectionSets.Item("BSS1").Delete
End With
Exit Sub
SSErr:
ActiveDocument.SelectionSets.Item("BSS1").Delete
Set BlockSset = ActiveDocument.SelectionSets.Add("BSS1")
Err:
Resume Next
End Sub |
著作権者の許可を得ていないため削除
サンプルデータ
http://homepage2.nifty.com/kamegai/autocad/BlockRotationSet_SampleData.dwg
の、１６個の閉じたオブジェクトのうち、
最も左下のオブジェクト（４つある楕円のデータの左下）
ブロック
"ya" （上向きの矢印で形状は『↑』基点は下）が
DIVIDE[ディバイダ]
で回転させずに等間隔で挿入されています
で説明します。
BlockRotationSet を実行すると、
とコマンドラインに表示されるので、ブロックオブジェクトを選択。次に、
とコマンドラインに表示されるので、中心点(回転方向)を指示。
今回は楕円の中心に向かせたいとのことですので、楕円中心をピック。
xxx,yyyと座標値の直接入力や、"@"
の入力で直前の座標値を参照できます
次に、
で、 I
[ENTER]または、[ENTER]のみ入力
右クリックでポップアップメニューを表示させ、内向(In)または、ENTER(E)を選択でも可能です。
で、[ENTER]と入力
これで矢印のブロックが楕円中心方向に回転しないでしょうか？
『補正角を入力』は、『向きを指示』で各ブロック個別に算出した回転角に、
加算する値です。
コマンドラインに表示される
<>内の値は、[ENTER]のみ入力の場合に
選択される既定値です。
『補正角を入力』で[ENTER]のみ入力すると、既定値の "0"
を入力したことと
同じとなります。
サンプルデータのブロック"ya2"の様に９０度傾いている場合
（４つある楕円のデータの右下のオブジェクトを例にとりますと）
『補正角を入力』で、90
[ENTER] を入力すれば、
矢印のブロックが楕円中心方向に回転します。
これでもだめなら、またご質問下さい。
著作権者の許可を得ていないため削除
＞残念ながらサンプルデータが見れません。
ダウンロード出来ないということでしょうか？
それとも開けない？
AutoCAD
2000i で作成したデータで、
当方では、ダウンロード・開くとも問題なく出来ますが・・・
他の方も同じでしょうか？
著作権者の許可を得ていないため削除
＞左上に×が出てダメですね。
何の左上ですか？
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
＞インターネットエクスプローラーの画面の左上です。
理解できました。
以下のリンク先を『右クリック』して、対象をファイルに保存してください。
http://homepage2.nifty.com/kamegai/autocad/BlockRotationSet_SampleData.dwg
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
出来るはずですが・・・
再度、上記の説明をお読み下さい。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
＞2000iで動作確認しました。
お〜！ 私の他にも 2000i
使いの方がお見えになるとは（笑）
お？さん、動作確認ありがとうございました。
Getxxx関数をまだ十分に理解できていませんので、
戻値の処理がスマートではありませんが、
多少手直しとコメントの追加をしました。
何度も長文を書込むのはご迷惑と思い、以下にアップしておきます。
http://homepage2.nifty.com/kamegai/autocad/BRS.bas
上記のリンク先を『右クリック』で、対象をファイルに保存し、
Visual
Basic
エディタでファイルのインポートもしくは、
テキストエディタで開いてコピー＆貼り付けでご利用下さい。
ＶＢＡ使いの方でしたら、他に流用できるのでは？と思います。