| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
お世話になります。
とあるプログラムを作成中で、タイトル通り
「画層ごとのセレクションセットの作成」を
行いたいと思っております。
図中、すべてのオブジェクトを選択する場合、
セレクションセット作成時にフィルタリングをし、
それを必要な画層ごとに繰り返せば良いというのは
わかります。
今回行いたいのは
一度目に選択(SelectOnScreenにて)した範囲で
画層ごとにセレクションセットを作成したいのです。
SelectOnScreenの座標？を固定して複数回繰り返すようなことは出来ないのでしょうか?
思い浮かぶ方法としては
SelectOnScreenで選択したオブジェクトを
For
Each等でサーチしながら
個々の画層ごとに分割していく方法だと思うのですが、
オブジェクトの数が非常に多く、可能な限りLoop(総当り？）を使用したくないという事がありまして、
今回質問させて頂きました。
どなたかよき解決方法をお教え下さい。
よろしくお願いします。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
選択(SelectOnScreen)は１回のみで、画層ごとに振り分けます。
ただし、選択前に画層ごとの選択セットを用意していますので、
不要の選択セットが生じます。
SelectOnScreenを
For Each
で直接回した方が
早いような気がしますが・・・
下記のサンプルは、各画層の選択セットに振り分け後、
各オブジェクトにズームしています。
動作検証が十分ではありませんし、エラー処理も別途必要です。
長文失礼。
Option Explicit
' 開発・動作確認 2000i
'
Sub SelectOnScreenToSelectionSets()
Dim sset() As AcadSelectionSet '選択セット (0はSelectOnScreen用)
Dim entry As AcadEntity
Dim Addobj(0) As AcadEntity
Dim Layer As AcadLayer
Dim CheckFLG As Boolean
Dim I As Long
Dim J As Long
Dim Response As Long
Dim Msg As String
Dim SSHead As String
Dim SSName() As String
On Error GoTo ERR:
ReDim sset(0)
ReDim SSName(0)
'
SSHead = "SS_"
SSName(0) = SSHead & "ALL"
On Error GoTo SSErr2:
Set sset(0) = ActiveDocument.SelectionSets.Add(SSName(0))
On Error GoTo ERR:
'画層分の選択セットを作成 sset(1〜)
For Each Layer In ActiveDocument.Layers
ReDim Preserve SSName(0 To UBound(SSName) + 1)
ReDim Preserve sset(0 To UBound(sset) + 1)
'新しい選択セット名を作成
SSName(UBound(SSName)) = SSHead & Layer.Name
On Error GoTo SSErr1:
'新しい選択セットを作成
Set sset(UBound(sset)) = ActiveDocument.SelectionSets.Add(SSName(UBound(SSName)))
On Error GoTo ERR:
Next Layer
On Error GoTo ERR:
'////////////////////////////////////
sset(0).SelectOnScreen
'////////////////////////////////////
If sset(0).Count > 0 Then
'各選択セットに振り分け
For Each entry In sset(0)
CheckFLG = False
For I = 1 To UBound(sset)
If SSName(I) = SSHead & entry.Layer Then
Set Addobj(0) = entry
sset(I).AddItems Addobj
Set Addobj(0) = Nothing
CheckFLG = True
End If
Next I
If Not CheckFLG Then
MsgBox "選択セットに振り分けエラー ", vbOKOnly + vbCritical
'選択セット 削除
For J = 0 To UBound(sset)
ActiveDocument.SelectionSets.Item(SSName(J)).Delete
Next J
Exit Sub
End If
Next entry
'***********************
For I = 1 To UBound(sset)
'各選択セットの個数確認 ----------------------------------------------------------
' 使用時は削除してください
Msg = SSName(I) & " : " & sset(I).Count & vbCr & vbCr & " 続行しますか。 "
Response = MsgBox(Msg, vbOKCancel)
If Response = vbOK Then
Else
Exit For
End If
'--------------------------------------------------------------------------------
If sset(I).Count > 0 Then
For Each entry In sset(I)
'必要な処理
Call GetObjectArea(entry) ' 使用時は削除してください
'・・・
Next entry
Else
'ユーザが画面上で選択したオブジェクトに該当する画層は無かった
End If
Next I
'***********************
Else
MsgBox "何も選択されていません ", vbOKOnly + vbInformation
End If
'選択セット 削除
For J = 0 To UBound(sset)
ActiveDocument.SelectionSets.Item(SSName(J)).Delete
Next J
Exit Sub
SSErr2:
ActiveDocument.SelectionSets.Item(SSName(0)).Clear '選択セット クリア
ActiveDocument.SelectionSets.Item(SSName(0)).Delete '選択セット 削除
Set sset(0) = ActiveDocument.SelectionSets.Add(SSName(0)) '選択セット 作成
Resume Next
SSErr1:
ActiveDocument.SelectionSets.Item(SSName(UBound(SSName))).Clear '選択セット クリア
ActiveDocument.SelectionSets.Item(SSName(UBound(SSName))).Delete '選択セット 削除
Set sset(UBound(sset)) = ActiveDocument.SelectionSets.Add(SSName(UBound(SSName))) '選択セット 作成
ERR:
Resume Next
End Sub
'オブジェクトにズーム
Private Sub GetObjectArea(Obj)
Dim ZoomWindowLowerLeftpoint(0 To 2) As Double
Dim ZoomWindowUpperRightpoint(0 To 2) As Double
Dim N As Double '倍率
Dim W As Double '幅
Dim H As Double '高さ
Dim CX As Double
Dim CY As Double
Dim ZWLL(0 To 1) As Double
Dim ZWUR(0 To 1) As Double
Dim minExt As Variant
Dim maxExt As Variant
Dim OpenForms As Variant
On Error GoTo ERR:
Obj.GetBoundingBox minExt, maxExt
ZWLL(0) = minExt(0): ZWLL(1) = minExt(1): ZWLL(2) = minExt(2)
ZWUR(0) = maxExt(0): ZWUR(1) = maxExt(1): ZWUR(2) = maxExt(2)
N = 0.8 '倍率
CX = (ZWLL(0) + ZWUR(0)) / 2
CY = (ZWLL(1) + ZWUR(1)) / 2
W = Abs(ZWLL(0) - ZWUR(0)) / N
H = Abs(ZWLL(1) - ZWUR(1)) / N
ZWLL(0) = CX - W / 2
ZWLL(1) = CY - H / 2
ZWUR(0) = CX + W / 2
ZWUR(1) = CY + H / 2
ZoomWindowLowerLeftpoint(0) = ZWLL(0)
ZoomWindowLowerLeftpoint(1) = ZWLL(1)
ZoomWindowUpperRightpoint(0) = ZWUR(0)
ZoomWindowUpperRightpoint(1) = ZWUR(1)
ZoomWindow ZoomWindowLowerLeftpoint, ZoomWindowUpperRightpoint
DoEvents
Exit Sub
ERR:
'[キャンセル/ESC]を２回送信
ActiveDocument.SendCommand Chr(3) & Chr(3)
DoEvents
Resume Next
End Sub |
訂正
＃オブジェクトにズームの"ZWLL(2) =
minExt(2)"と"ZWUR(2) = maxExt(2)"削除
Option Explicit
' 開発・動作確認 2000i
'
Sub SelectOnScreenToSelectionSets()
Dim sset() As AcadSelectionSet '選択セット (0はSelectOnScreen用)
Dim entry As AcadEntity
Dim Addobj(0) As AcadEntity
Dim Layer As AcadLayer
Dim CheckFLG As Boolean
Dim I As Long
Dim J As Long
Dim Response As Long
Dim Msg As String
Dim SSHead As String
Dim SSName() As String
On Error GoTo ERR:
ReDim sset(0)
ReDim SSName(0)
'
SSHead = "SS_"
SSName(0) = SSHead & "ALL"
On Error GoTo SSErr2:
Set sset(0) = ActiveDocument.SelectionSets.Add(SSName(0))
On Error GoTo ERR:
'画層分の選択セットを作成 sset(1〜)
For Each Layer In ActiveDocument.Layers
ReDim Preserve SSName(0 To UBound(SSName) + 1)
ReDim Preserve sset(0 To UBound(sset) + 1)
'新しい選択セット名を作成
SSName(UBound(SSName)) = SSHead & Layer.Name
On Error GoTo SSErr1:
'新しい選択セットを作成
Set sset(UBound(sset)) = ActiveDocument.SelectionSets.Add(SSName(UBound(SSName)))
On Error GoTo ERR:
Next Layer
On Error GoTo ERR:
'////////////////////////////////////
sset(0).SelectOnScreen
'////////////////////////////////////
If sset(0).Count > 0 Then
'各選択セットに振り分け
For Each entry In sset(0)
CheckFLG = False
For I = 1 To UBound(sset)
If SSName(I) = SSHead & entry.Layer Then
Set Addobj(0) = entry
sset(I).AddItems Addobj
Set Addobj(0) = Nothing
CheckFLG = True
End If
Next I
If Not CheckFLG Then
MsgBox "選択セットに振り分けエラー ", vbOKOnly + vbCritical
'選択セット 削除
For J = 0 To UBound(sset)
ActiveDocument.SelectionSets.Item(SSName(J)).Delete
Next J
Exit Sub
End If
Next entry
'***********************
For I = 1 To UBound(sset)
'各選択セットの個数確認 ----------------------------------------------------------
' 使用時は削除してください
' Msg = SSName(I) & " : " & sset(I).Count & vbCr & vbCr & " 続行しますか。 "
' Response = MsgBox(Msg, vbOKCancel)
' If Response = vbOK Then
' Else
' Exit For
' End If
'--------------------------------------------------------------------------------
If sset(I).Count > 0 Then
For Each entry In sset(I)
'必要な処理
Call GetObjectArea(entry) ' 使用時は削除してください
'・・・
Next entry
Else
'ユーザが画面上で選択したオブジェクトに該当する画層は無かった
End If
Next I
'***********************
Else
MsgBox "何も選択されていません ", vbOKOnly + vbInformation
End If
'選択セット 削除
For J = 0 To UBound(sset)
ActiveDocument.SelectionSets.Item(SSName(J)).Delete
Next J
Exit Sub
SSErr2:
ActiveDocument.SelectionSets.Item(SSName(0)).Clear '選択セット クリア
ActiveDocument.SelectionSets.Item(SSName(0)).Delete '選択セット 削除
Set sset(0) = ActiveDocument.SelectionSets.Add(SSName(0)) '選択セット 作成
Resume Next
SSErr1:
ActiveDocument.SelectionSets.Item(SSName(UBound(SSName))).Clear '選択セット クリア
ActiveDocument.SelectionSets.Item(SSName(UBound(SSName))).Delete '選択セット 削除
Set sset(UBound(sset)) = ActiveDocument.SelectionSets.Add(SSName(UBound(SSName))) '選択セット 作成
ERR:
Resume Next
End Sub
'オブジェクトにズーム
Private Sub GetObjectArea(Obj)
Dim ZoomWindowLowerLeftpoint(0 To 2) As Double
Dim ZoomWindowUpperRightpoint(0 To 2) As Double
Dim N As Double '倍率
Dim W As Double '幅
Dim H As Double '高さ
Dim CX As Double
Dim CY As Double
Dim ZWLL(0 To 1) As Double
Dim ZWUR(0 To 1) As Double
Dim minExt As Variant
Dim maxExt As Variant
Dim OpenForms As Variant
On Error GoTo ERR:
Obj.GetBoundingBox minExt, maxExt
ZWLL(0) = minExt(0): ZWLL(1) = minExt(1)
ZWUR(0) = maxExt(0): ZWUR(1) = maxExt(1)
N = 0.8 '倍率
CX = (ZWLL(0) + ZWUR(0)) / 2
CY = (ZWLL(1) + ZWUR(1)) / 2
W = Abs(ZWLL(0) - ZWUR(0)) / N
H = Abs(ZWLL(1) - ZWUR(1)) / N
ZWLL(0) = CX - W / 2
ZWLL(1) = CY - H / 2
ZWUR(0) = CX + W / 2
ZWUR(1) = CY + H / 2
ZoomWindowLowerLeftpoint(0) = ZWLL(0)
ZoomWindowLowerLeftpoint(1) = ZWLL(1)
ZoomWindowUpperRightpoint(0) = ZWUR(0)
ZoomWindowUpperRightpoint(1) = ZWUR(1)
ZoomWindow ZoomWindowLowerLeftpoint, ZoomWindowUpperRightpoint
DoEvents
Exit Sub
ERR:
'[キャンセル/ESC]を２回送信
ActiveDocument.SendCommand Chr(3) & Chr(3)
DoEvents
Resume Next
End Sub |
再度、修正など。
＃必要な選択セットのみ作成する方法に変更しました。
＃何度も長文をアップするのは気が引けるので、以下にアップしました。
http://www.geocities.jp/kamegai2006/autocad/SOS2SS05.lzh
で、以下素朴な疑問です。。。
＞「画層ごとのセレクションセットの作成」を・・・
必要性を理解できませんが、特別な理由があるのでしょうか？
選択セットの分岐（判別）がとてもめんどくさくなると思うのですが・・・
＃土木関連で画層名が決まっているのでしょうか？
＃選択セットで何をするかまでお書き下さると別の方法が見つかるかもしれません
＞オブジェクトの数が非常に多く、可能な限りLoop(総当り？）を使用したくないという事がありまして、
SelectOnScreenを複数回繰り返すうまい方法があったとしても、
当方がアップした総当りより時間がかかると思いますが・・・
＃当方の環境では、オブジェクト41,000強で、
＃SelectOnScreenで（グリップ表示完了までに）１２秒ほど、
＃画層ごとの選択セット作成に３秒ほどですが、、、実際の図面で試してみてください
＃３秒では長いといわれるのであれば、ObjectARXを考慮してみてください
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
少しばかり修正しました、最新版は以下からどうぞ。
http://www.geocities.jp/kamegai2006/autocad/index_2.htm#20080422
＞画層の数（不定数）×必要オブジェクトタイプ（定数）
＝SelectOnScreen回数で
かなり細かく分類されるようですが、やっぱり必要性を推察できません。
＃たとえば、分類したオブジェクトを複写しオリジナルを削除して、
＃SXF変換時の表示順を変える（ハンドル番号を振り直す）為とかですか？
＃書き込みいただく必要はありませんが・・・やはりちょっと気になるので・・・
＞字の色がおかしいのは何故？
今朝の私の書き込みからおかしくなったようです。
＃今朝、下記のフィードバックから管理人さんに連絡済みです。
ソースから判断すると、今朝のではなく昨夜から？
＃2008/04/21(月)
23:25:05の＃用？spanタグがpreタグに食い込んでいるようで、
＃でも、span終了タグが表示されないのが不明ですが。
＃この書き込みが不適切であれば削除してください
著作権者の許可を得ていないため削除