| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
いつもいつもいつも大変助かっております。
いまリージョンから情報を取得し、図心にマーキングをしているのですがその手順が少々まどろっこしいのでどなたかいい方法がありましたら教えてください。2009を使用しているので マクロ を使用するのも考えましたが、ちょっと躊躇しております。
現在の手順
① リージョンの情報より図心 ｘとｙ を確認します
② Ｌｉｎｅコマンド一点目に ① のｘとｙの座標をコピーそしてペースト
③ 2点目を適当に配置し一点目にマーキングを配置
以上です。リージョンの座標位置にポンポンポンと配置できないでしょうか？
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
http://www.mura.sh/bbs/wwwbbs.cgi?print+200104/01040063.txt
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
かなり出遅れですが、VBAで。
モデル空間のすべてまたは選択したリージョンの図心に点を配置します。
使用する手順。
1.[ツール]-[マクロ]-[VBA管理]で新規作成
2.[ツール]-[マクロ]-[Visual
Basic
エディタ]で統合開発環境(IDE)へ
3.新規作成されたプロジェクトを選択して[挿入]-[標準モジュール]
4.追加された標準モジュール"Module1"をクリックしして開き、
下記プログラムを貼付
5.AutoCADに戻り[ツール]-[マクロ]-[VBA管理]で”名前を付けて保存”
次回起動時はこのファイルを[ツール]-[マクロ]-[プロジェクトロード]で読み込みます
6.[ツール]-[マクロ]-[マクロ]で"CentroidOfRegion"または"CentroidOfRegion2"を
選択して実行します
頻繁に使用するならメニューボタンに
^C^C-vbarun;CentroidOfRegion^M
^C^C-vbarun;CentroidOfRegion2^M
と登録してください。
不具合あれば書き込んでください。長文失礼。
Option Explicit
'ModelSpaceにあるすべてのリージョンの図心(Zは現在の高度)に点をプロット
Public Sub CentroidOfRegion()
Dim Elem As AcadEntity
Dim PointObj As AcadPoint
Dim N As Integer '丸め（有効桁数）[0<N<15]
Dim Location(0 To 2) As Double
Dim Centroid As Variant
On Error GoTo Err:
N = 15
Location(2) = ActiveDocument.GetVariable("ELEVATION")
For Each Elem In ActiveDocument.ModelSpace
If StrComp(TypeName(Elem), "IAcadRegion", 1) = 0 Then
Centroid = Elem.Centroid
Location(0) = RoundNDigits(Centroid(0), N)
Location(1) = RoundNDigits(Centroid(1), N)
Set PointObj = ActiveDocument.ModelSpace.AddPoint(Location)
End If
Set PointObj = Nothing
Next
Exit Sub
Err:
Set PointObj = Nothing
ActiveDocument.Utility.Prompt "*ERR*"
End Sub
'ユーザーが選択したリージョンの図心(Zは現在の高度)に点をプロット
Public Sub CentroidOfRegion2()
Dim ObjctSset As AcadSelectionSet
Dim Elem As AcadEntity
Dim PointObj As AcadPoint
Dim N As Integer '丸め（有効桁数）[0<N<15]
Dim Location(0 To 2) As Double
Dim Centroid As Variant
'
Dim FilterType(0 To 1) As Integer
Dim FilterData(0 To 1) As Variant
On Error GoTo SSErr:
Set ObjctSset = ActiveDocument.SelectionSets.Add("RegionSset")
On Error GoTo Err:
N = 15
FilterType(0) = 0: FilterData(0) = "Region"
FilterType(1) = 67: FilterData(1) = 0 'Modelspace
ObjctSset.SelectOnScreen FilterType, FilterData
If ObjctSset.Count > 0 Then
Location(2) = ActiveDocument.GetVariable("ELEVATION")
For Each Elem In ObjctSset
If StrComp(TypeName(Elem), "IAcadRegion", 1) = 0 Then
Centroid = Elem.Centroid
Location(0) = RoundNDigits(Centroid(0), N)
Location(1) = RoundNDigits(Centroid(1), N)
Set PointObj = ActiveDocument.ModelSpace.AddPoint(Location)
End If
Next Elem
Set PointObj = Nothing
End If
Set ObjctSset = Nothing
ActiveDocument.SelectionSets.Item("RegionSset").Delete
Exit Sub
SSErr:
ActiveDocument.SelectionSets.Item("RegionSset").Delete
Set ObjctSset = ActiveDocument.SelectionSets.Add("RegionSset")
Resume Next
Err:
Set PointObj = Nothing
Set ObjctSset = Nothing
ActiveDocument.SelectionSets.Item("RegionSset").Delete
ActiveDocument.Utility.Prompt "*ERR*"
End Sub
'有効桁数Ｎ桁で丸め [戻値:Double]
Public Function RoundNDigits(X As Variant, N As Integer) As Double
On Error GoTo Err:
If N > 15 Or N < 1 Then
RoundNDigits = CDbl(X)
Else
RoundNDigits = CDbl(Format(CDbl(X), "0." & String(N - 1, "0") & "E+000"))
End If
Exit Function
Err:
End Function
|
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
３Ｄ回転したリージョンにも対応しました（完全ではありませんが・・・）
長文なので選択版やコメント等を省略しています。
＃フルバージョン http://www.geocities.jp/kamegai2006/autocad/index_2.htm#20090207
不具合あれば書き込んでください。長文失礼。
Option Explicit
'ModelSpaceにあるすべてのリージョンの図心に点をプロット
Public Sub CentroidOfRegion()
Dim Elem As AcadEntity
Dim PointObj As AcadPoint
Dim Location(0 To 2) As Double
Dim Centroid, LocationV, WCSPnt
On Error GoTo ERR:
LocationV = Location 'VariantのDouble化
For Each Elem In ActiveDocument.ModelSpace
If StrComp(TypeName(Elem), "IAcadRegion", 1) = 0 Then
On Error Resume Next
Centroid = Elem.Centroid
If ERR.Number = 0 Then
On Error GoTo ERR:
LocationV(0) = RoundNDigits(Centroid(0), 15) '丸め（有効桁数:15）[<=15]
LocationV(1) = RoundNDigits(Centroid(1), 15)
LocationV(2) = ActiveDocument.GetVariable("ELEVATION")
ElseIf ERR.Number = -2145320934 Then
On Error GoTo ERR:
If Not GetCentroidOfRegionByUCS(Elem, LocationV, 15) Then
Error 51: Exit Sub
End If
Else
Error 51: Exit Sub
End If
WCSPnt = ActiveDocument.Utility.TranslateCoordinates(LocationV, acUCS, acWorld, False) 'World ← UCS
Location(0) = WCSPnt(0): Location(1) = WCSPnt(1): Location(2) = WCSPnt(2)
Set PointObj = ActiveDocument.ModelSpace.AddPoint(Location)
PointObj.Update
End If
Set PointObj = Nothing
Next
Exit Sub
ERR:
Set PointObj = Nothing
ActiveDocument.Utility.Prompt "*ERR(" & CStr(ERR.Number) & ")*"
End Sub
'有効桁数Ｎ桁で丸め [戻値:Double]
Private Function RoundNDigits(X As Variant, ByVal N As Integer) As Double
If N > 15 Or N < 1 Then N = 15
RoundNDigits = CDbl(Format(CDbl(X), "0." & String(N - 1, "0") & "E+000"))
End Function
'OCS(引数Elemのオブジェクト座標系)で図心取得
Private Function GetCentroidOfRegionByUCS(Elem As AcadEntity, LV As Variant, N As Integer) As Boolean
Dim UCSObj As AcadUCS
Dim CurrUCS As AcadUCS
Dim ERRFLG As Boolean
Dim CurrOSMODE As Integer
Dim I As Long
Dim T(0 To 2) As Double
Dim Z(0 To 2) As Double
Dim Origin(0 To 2) As Double
Dim XAP(0 To 2) As Double
Dim YAP(0 To 2) As Double
Dim UCS_Name As String
Dim CP, EN, VP, P2D, P3D, WCSPnt, Centroid, ExplodedObjects
On Error GoTo ERR:
Set CurrUCS = ActiveDocument.ActiveUCS
CurrOSMODE = ActiveDocument.GetVariable("OSMODE")
ActiveDocument.SetVariable "OSMODE", 0
LV = T 'VariantのDouble化
UCS_Name = "GetCentroidOfRegionByUCS_" & CStr(CDbl(Now))
ExplodedObjects = Elem.Explode
Select Case TypeName(ExplodedObjects(0))
Case "IAcadLine"
P3D = ExplodedObjects(0).StartPoint
Case "IAcadArc", "IAcadCircle", "IAcadEllipse"
P3D = ExplodedObjects(0).Center
Case "IAcadLWPolyline"
ReDim P3D(0 To 2)
P2D = ExplodedObjects(0).Coordinate(0)
P3D(0) = P2D(0): P3D(1) = P2D(1): P3D(2) = Elem.Elevation
Case "IAcadSpline"
ReDim P3D(0 To 2)
CP = ExplodedObjects(0).ControlPoints
P3D(0) = CP(0): P3D(1) = CP(1): P3D(2) = CP(2)
Case Else
Exit Function
End Select
For I = LBound(ExplodedObjects) To UBound(ExplodedObjects)
ExplodedObjects(I).Delete
Next I
Origin(0) = P3D(0): Origin(1) = P3D(1): Origin(2) = P3D(2)
EN = Elem.Normal
RETRY:
If Round(EN(0), 15) = 0 And Round(EN(1), 15) = 0 Then '小数点以下15桁で丸め
XAP(0) = 1#: XAP(1) = 0#: XAP(2) = 0#
YAP(0) = 0#: YAP(1) = 1#: YAP(2) = 0#
Else
If Not GetObjectOCS(EN, XAP, YAP) Then Exit Function
End If
XAP(0) = XAP(0) + Origin(0): XAP(1) = XAP(1) + Origin(1): XAP(2) = XAP(2) + Origin(2)
YAP(0) = YAP(0) + Origin(0): YAP(1) = YAP(1) + Origin(1): YAP(2) = YAP(2) + Origin(2)
Set UCSObj = ActiveDocument.UserCoordinateSystems.Add(Origin, XAP, YAP, UCS_Name)
ActiveDocument.ActiveUCS = UCSObj
Centroid = Elem.Centroid
LV(0) = RoundNDigits(Centroid(0), N): LV(1) = RoundNDigits(Centroid(1), N): LV(2) = 0#
WCSPnt = ActiveDocument.Utility.TranslateCoordinates(LV, acUCS, acWorld, False) 'World ← UCS
LV = WCSPnt
ActiveDocument.ActiveUCS = CurrUCS
ActiveDocument.SetVariable "OSMODE", CurrOSMODE
ActiveDocument.UserCoordinateSystems.Item(UCS_Name).Delete
Set UCSObj = Nothing: Set CurrUCS = Nothing
GetCentroidOfRegionByUCS = True
Exit Function
ERR:
If (ERR.Number = -2145320934 Or ERR.Number = -2145320930) And (Not ERRFLG) Then
EN(0) = EN(0) * 1000#: EN(1) = EN(1) * 1000#: EN(2) = EN(2) * 1000#
ERR.Clear
ERRFLG = True
GoTo RETRY:
End If
ActiveDocument.SendCommand "*ERR_xyz(" & CStr(P3D(0)) & "," & P3D(1) & "," & P3D(2) & ")*" & Chr(3)
ActiveDocument.SetVariable "OSMODE", CurrOSMODE
ActiveDocument.ActiveUCS = CurrUCS
Set UCSObj = Nothing: Set CurrUCS = Nothing
ActiveDocument.UserCoordinateSystems.Item(UCS_Name).Delete
End Function
'図形独自の座標系(OCS)を求める
Public Function GetObjectOCS(Normal As Variant, Ax() As Double, Ay() As Double) As Boolean
Dim Wy(0 To 2) As Double '常に (0,1,0)
Dim Wz(0 To 2) As Double '常に (0,0,1)
Dim BoundaryValue As Double '境界の値 1/64
On Error GoTo ERR:
If Not IsArray(Normal) Then Exit Function
If LBound(Normal) <> 0 Or UBound(Normal) <> 2 Then Exit Function
Wy(0) = 0#: Wy(1) = 1#: Wy(2) = 0#:
Wz(0) = 0#: Wz(1) = 0#: Wz(2) = 1#:
BoundaryValue = 1# / 64#
If Abs(Normal(0)) < BoundaryValue And Abs(Normal(1)) < BoundaryValue Then
Ax(0) = 1# * CDbl(Normal(2)) - 0# * CDbl(Normal(1))
Ax(1) = 0# * CDbl(Normal(0)) - 0# * CDbl(Normal(2))
Ax(2) = 0# * CDbl(Normal(1)) - 1# * CDbl(Normal(0))
Else
Ax(0) = 0# * CDbl(Normal(2)) - 1# * CDbl(Normal(1))
Ax(1) = 1# * CDbl(Normal(0)) - 0# * CDbl(Normal(2))
Ax(2) = 0# * CDbl(Normal(1)) - 0# * CDbl(Normal(0))
End If
Ay(0) = CDbl(Normal(1)) * Ax(2) - CDbl(Normal(2)) * Ax(1)
Ay(1) = CDbl(Normal(2)) * Ax(0) - CDbl(Normal(0)) * Ax(2)
Ay(2) = CDbl(Normal(0)) * Ax(1) - CDbl(Normal(1)) * Ax(0)
GetObjectOCS = True
Exit Function
ERR:
End Function |
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
＞kamegai
さんのは分解してからデータを取得していると思うのですが、
リージョン上の任意の１点の座標値が必要なだけですが、
他の方法が解からなかったので。
で、かなり修正・変更をしました。
＃長文なのでこれ以上のソースの書き込みはやめておきます
＃以下からどうぞ
＃http://www.geocities.jp/kamegai2006/autocad/index_2.htm#20090207
不具合あれば書き込んでください。