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
-------------------------------------------------

0 件のコメント:

コメントを投稿