2011年2月26日土曜日

.NET - 異なる値で連続オフセットするプログラムを作ってみました(AutoCAD 2011)


先日異なる値で連続オフセットする(AutoCAD 2011)で書きましたが、異なる値で連続オフセットするプログラムを作ってみました。

GetOffsetCurves メソッドでオフセットできるみたいだったので、結構簡単に作れるのかなと思って始めたんですた、なかなか難しかったです。


最初につまずいたのは、AutoCAD の OFFSET コマンドみたいにオフセットする側をクリックして指定できたら便利だと思ったんですが、どうやってやればいいのやら???

そのためのメソッドとかなにかあるのかなと思ったんですが、見つけられませんでした。
いろいろググッても見たんですが、それでも何も見つけられなくて…

ほとんど諦めかけてたんですが、ひょっとして 「元のオブジェクト と クリックした点の最短距離」 と 「オフセットしたオブジェクト と リックした点の最短距離」 を比較すればいのかなって思ってやってみたらできました。

もっといい方法があるのかどうかは分かりませんが、とりあえずできたのでよしとしましょう。


GetClosestPointTo メソッドで、クリックした点から一番近いオブジェクト上の点を求めて、DistanceTo メソッドで距離を求めました。

で、連続オフセットする最初の一回目だけ、 「元のオブジェクト と クリックした点の最短距離」 と 「オフセットしたオブジェクト と リックした点の最短距離」 を比較して、前者より後者の方が大きかったときはオフセットする方向を反対にしました。


それと、UCS を変更するとうまくいかないことがあるみたいだったので、UCS を WCS に変換するっていう手順も追加しました。


コードはこんな感じです。
' ---------------------------------------------
Imports System
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports AVDO_Offset.DemandLoading.RegistryUpdate

' This line is not mandatory, but improves loading performances
<Assembly: CommandClass(GetType(AVDO_Offset.MyCommands))>

Namespace AVDO_Offset

    Public Class MyCommands
        <CommandMethod("AVDO_Offset", "AVDO_Offset", CommandFlags.Modal + CommandFlags.UsePickSet)> _
        Public Sub AVDO_Offset()
            Dim doc As Document = Application.DocumentManager.MdiActiveDocument
            Dim db As Database = doc.Database
            Dim ed As Editor = doc.Editor

            ' オフセットのために選択したオブジェクトのオブジェクトID
            Dim selEntID As ObjectId

            ' PickFirst 選択セットを取得
            Dim psr As PromptSelectionResult = ed.SelectImplied()

            If psr.Status = PromptStatus.OK Then
                If psr.Value.Count > 1 Then
                    ' 複数のオブジェクトが PickFirst 選択セットに含まれているときは、ひとつのオブジェクトを選択しなおす
                    selEntID = ed.GetEntity("オブジェクトを選択").ObjectId
                Else
                    ' ひとつだけのオブジェクトが PickFirst 選択セットに含まれているときは、そのオブジェクトIDを使用
                    selEntID = psr.Value.GetObjectIds(0)
                End If
            Else
                ' PickFirst 選択セットを取得できなかったときオブジェクトをオブジェクトを選択する
                selEntID = ed.GetEntity(vbCrLf & "オブジェクトを選択").ObjectId
            End If

            ' 何も選択されていなかったら、コマンドを終了する
            If selEntID.IsValid = False Then
                Return
            End If


            Using trans As Transaction = db.TransactionManager.StartTransaction
                Dim ent As Entity = trans.GetObject(selEntID, OpenMode.ForRead)

                ' 選択されたオブジェクトが、オフセットの対象でない場合はコマンドを終了する
                If (TypeOf ent Is Line) _
                        Or (TypeOf ent Is Arc) _
                        Or (TypeOf ent Is Circle) _
                        Or (TypeOf ent Is Ellipse) _
                        Or (TypeOf ent Is Polyline) _
                        Or (TypeOf ent Is Polyline2d) _
                        Or (TypeOf ent Is Spline) _
                        Or (TypeOf ent Is Xline) Then
                Else
                    ed.WriteMessage(vbCrLf & "このオブジェクトはオフセットできません。")
                    Return
                End If
            End Using
          

            ' オフセットする方向を指定
            Dim ppo As PromptPointOptions = New PromptPointOptions(vbCrLf & "オフセットする側の点を指定")
            Dim ppr As PromptPointResult

            ppr = ed.GetPoint(ppo)

            If ppr.Status <> PromptStatus.OK Then
                Return
            End If

            ' オフセットする距離
            Dim dist As Double = 0

            ' オフセットする距離の追加分
            Dim distAdd As Double = 0

            ' オフセットしている回数
            Dim cnt As Integer = 0

            ' オフセットする側
            Dim ofstDirection As Boolean = True

            While True
                Using trans As Transaction = db.TransactionManager.StartTransaction
                    Try
                        Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
                        Dim btRec As BlockTableRecord

                        Dim cSpace As BlockTableRecord = trans.GetObject(db.CurrentSpaceId, OpenMode.ForRead)
                        If cSpace.Name = "*Model_Space" Then
                            btRec = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
                        Else
                            btRec = trans.GetObject(bt(BlockTableRecord.PaperSpace), OpenMode.ForWrite)
                        End If

                        ' 選択したオブジェクトに対して実行
                        Dim ent As Entity = trans.GetObject(selEntID, OpenMode.ForRead)

                        'オフセットされたオブジェクトコレクション
                        Dim dbObjColl As DBObjectCollection = Nothing

                        ' オフセットする距離を入力させる
                        Dim pdo As PromptDistanceOptions
                        If cnt = 0 Then
                            pdo = New PromptDistanceOptions(vbCrLf & "距離を指定してください")
                        Else
                            pdo = New PromptDistanceOptions(vbCrLf & "距離を指定してください<" & distAdd & ">")
                        End If
                        pdo.AllowNone = True
                        pdo.AllowNegative = False
                        pdo.Keywords.Add("eXit", "eXit", "終了(X)")

                        Dim pdr As PromptDoubleResult

                        pdr = ed.GetDistance(pdo)

                        If pdr.Status <> PromptStatus.None Then
                            distAdd = pdr.Value
                        End If

                        ' [終了(X)] オプションが選択されたときは、コマンドを終了
                        If pdr.StringResult = "eXit" Then
                            Return
                        End If

                        If cnt = 0 Then
                            If pdr.Status <> PromptStatus.OK Then
                                Return
                            End If
                        Else
                            If (pdr.Status <> PromptStatus.OK) And (pdr.Status <> PromptStatus.None) Then
                                Return
                            End If
                        End If


                        dist = dist + distAdd

                        ' それぞれのオブジェクトに対するオブジェクトコレクションを作成
                        Dim ofstent As Curve = ent

                        ' GetOffsetCurves で使うオフセット値
                        Dim ofstDist As Double
                        If ofstDirection = True Then
                            ofstDist = dist
                        Else
                            ofstDist = 0 - dist
                        End If

                        ' オフセットしたオブジェクトを作成
                        Try
                            dbObjColl = ofstent.GetOffsetCurves(ofstDist)
                        Catch ex As Autodesk.AutoCAD.Runtime.Exception
                            ed.WriteMessage(vbCrLf & "このオブジェクトはオフセットできません。")
                            Return
                        End Try

                        ' UCS を WCS に変換
                        Dim vpTblRec As ViewportTableRecord = trans.GetObject(doc.Editor.ActiveViewportId, OpenMode.ForWrite)

                        Dim newMatrix As Matrix3d = New Matrix3d()
                        newMatrix = Matrix3d.AlignCoordinateSystem(Point3d.Origin, _
                                                     Vector3d.XAxis, _
                                                     Vector3d.YAxis, _
                                                     Vector3d.ZAxis, _
                                                     vpTblRec.Ucs.Origin, _
                                                     vpTblRec.Ucs.Xaxis, _
                                                     vpTblRec.Ucs.Yaxis, _
                                                     vpTblRec.Ucs.Zaxis)

                        Dim pprWCS As Point3d = ppr.Value.TransformBy(newMatrix)


                        ' オフセットする側が正しいか確認し、間違っていれば反対にする
                        Dim distOrg As Double = ofstent.GetClosestPointTo(pprWCS, True).DistanceTo(pprWCS)  ' 元のオブジェクトと指定した点の距離
                        Dim distOfst As Double = distPtoObjColl(pprWCS, dbObjColl)  ' オフセットしたオブジェクトと指定した点の距離

                        ' 最初のオフセットのときに、オフセットする側が正しいか確認
                        If (cnt = 0) And (distOrg < distOfst) Then
                            dbObjColl.Dispose()
                            Try
                                dbObjColl = ofstent.GetOffsetCurves(-dist)
                            Catch ex As Autodesk.AutoCAD.Runtime.Exception
                                ed.WriteMessage(vbCrLf & "このオブジェクトはオフセットできません。")
                                Return
                            End Try
                            ofstDirection = False
                        End If

                        cnt += 1

                        ' オフセットされたオブジェクトを追加
                        If dbObjColl <> Nothing Then
                            For Each acEnt As Entity In dbObjColl
                                btRec.AppendEntity(acEnt)
                                trans.AddNewlyCreatedDBObject(acEnt, True)
                            Next
                        End If

                        trans.Commit()

                    Catch ex As Autodesk.AutoCAD.Runtime.Exception
                        MsgBox(ex.Message)

                    End Try
                End Using
            End While
        End Sub

        ' ある点と、オブジェクトコレクションにあるオブジェクトの最短距離を求める関数
        Public Function distPtoObjColl(ByVal pt As Point3d, ByVal dbObjColl As DBObjectCollection) As Double
            Dim dist As Double = 10 ^ 100

            For Each acEnt As Curve In dbObjColl
                Dim pt2 As Point3d = acEnt.GetClosestPointTo(pt, True)
                Dim distTemp As Double = pt.DistanceTo(pt2)
                If distTemp < dist Then
                    dist = distTemp
                End If
            Next

            Return dist
        End Function
    End Class
End Namespace
' ---------------------------------------------

2011年2月3日木曜日

.NET でプロファイルを変更する(AutoCAD 2011)


プロファイルを変更するには[オプション]ダイアログの[プロファイル]タブで、変更したいプロファイルをダブルクリックするんですが、ちょっと面倒くさいなと思って .NET でコマンド作れないかいろいろググリながらやってみました。

私の場合は以下の 2D 用と 3D 用のプロファイルがあります。
ACAD Video 2D
ACAD Video 3D

それを入れ替えるコマンドを作ってみました。
2D 用のプロファイルにするコマンド : AVDO_2D
3D 用のプロファイルにするコマンド : AVDO_3D
コードはこんな感じです。
--------------------------------------------------
Imports System
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Interop

' This line is not mandatory, but improves loading performances
<Assembly: CommandClass(GetType(AVDO_ChWsProfile.MyCommands))>

Namespace AVDO_ChWsProfile

    Public Class MyCommands

        Const p2d As String = "ACAD Video 2D"      ' 2D 用のプロファイルの名前
        Const p3d As String = "ACAD Video 3D"      ' 3D 用のプロファイルの名前

        <CommandMethod("AVDO_ChWsProfile", "AVDO_2D", "AVDO_2D", CommandFlags.Modal)> _
        Public Sub AVDO_2D()
            Dim ap As AcadPreferences = Application.Preferences

            If ap.Profiles.ActiveProfile = p2d Then
                MsgBox("プロファイルは既に " & p2d & " になっています。")
                Return
            End If

            If ChProperty(p2d) Then
                ap.Profiles.ActiveProfile = p2d
            Else
                MsgBox(p2d & " というプロファイルがありません。")
            End If

        End Sub

        <CommandMethod("AVDO_ChWsProfile", "AVDO_3D", "AVDO_3D", CommandFlags.Modal)> _
        Public Sub AVDO_3D()
            Dim ap As AcadPreferences = Application.Preferences

            If ap.Profiles.ActiveProfile = p3d Then
                MsgBox("プロファイルは既に " & p3d & " になっています。")
                Return
            End If

            If ChProperty(p3d) Then
                ap.Profiles.ActiveProfile = p3d
            Else
                MsgBox(p3d & " というプロファイルがありません。")
            End If
        End Sub

        ' 指定したプロファイルが存在するかどうかを確認する関数
        Public Function ChProperty(ByVal pName As String)
            Dim ap As AcadPreferences = Application.Preferences

            ' 存在するプロパティの取得
            Dim Profiles As Object = Nothing
            ap.Profiles.GetAllProfileNames(Profiles)

            For Each pr In Profiles
                ' もし、指定したプロファイルが存在すれば、True を返す
                If pr.ToString = pName Then
                    Return True
                End If
            Next

            Return False
        End Function
    End Class
End Namespace
-------------------------------------------------