Archive |mura's home- [AutoCAD掲示板 - 始終点一致のポリラインを時計回りに]09020051|

質問させてください。
当方autocad2006を使っています、VBA、LISP共に初心者です。

始終点が一致しているLWPLINEが多数あり
ポリラインの方向が時計回り、反時計回りのものが入り混じっています。
これを指定したlayer内の全てを時計回りにする方法はありませんでしょうか？
よろしくお願いします。

▼ kamegai [HOMEPAGE] 2009/02/09(月) 13:40:05

＞これを指定したlayer内の全てを
ではありませんが、表示（アンフリーズ・アンロック）画層の
すべてのライトウェイトポリラインの座標順を時計回りにします。
なので、除外したい画層は非表示（またはフリーズかロック）にしてください。
計回り・逆時計回りは、法線の座標系の平面図で判断します。
＃よって３Ｄ反転していると、見た目は指定と逆順になります
＃始終点が一致は設定していませんので、必須条件であれば追加の必要があります

使用する手順。
1.[ツール]-[マクロ]-[VBA管理]で新規作成
2.[ツール]-[マクロ]-[Visual Basic エディタ]で統合開発環境(IDE)へ
3.新規作成されたプロジェクトを選択して[挿入]-[標準モジュール]
4.追加された標準モジュール"Module1"をクリックしして開き、
　下記プログラムを貼付
5.AutoCADに戻り[ツール]-[マクロ]-[VBA管理]で”名前を付けて保存”
　次回起動時はこのファイルを[ツール]-[マクロ]-[プロジェクトロード]で読み込みます
6.[ツール]-[マクロ]-[マクロ]で"SetLWPolyline"を選択して実行します
＃逆時計回りの場合は該当箇所を変更してください
＃ライトウェイトポリラインの始終点反転は、
＃http://www.mura.sh/bbs/wwwbbs.cgi?print+200712/07120085.txt
＃のものに同じです

不具合あれば書き込んでください。長文失礼。

Option Explicit
'ライトウェイトポリラインの座標順を時計回りに（または反時計回りに）
Public Sub SetLWPolyline()
'  対象:ModelSpaceにある表示（アンフリーズ・アンロック）画層のライトウェイトポリライン
'       閉じている・いないは不問（ただし自身が交差する場合の結果は不定）
'  条件:時計回り・逆時計回りは、法線の座標系の平面図で判断します
Dim ObjctSset     As AcadSelectionSet
Dim Ssobj(0 To 0) As AcadEntity
Dim LWPLElem      As AcadEntity
Dim I             As Long
Dim Count         As Long
Dim CountAll      As Long
Dim Area1         As Double
Dim Area2         As Double
Dim OffsetObj1    As Variant
Dim OffsetObj2    As Variant
    On Error GoTo SSErr:
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    On Error GoTo ERR:
    Count = 0
    CountAll = 0
    'リスト作成
    For Each LWPLElem In ActiveDocument.ModelSpace
        If StrComp(TypeName(LWPLElem), "IAcadLWPolyline", 1) = 0 Then
            If ActiveDocument.Layers(LWPLElem.Layer).LayerOn And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Lock And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Freeze Then
                Set Ssobj(0) = LWPLElem
                ObjctSset.AddItems Ssobj
                CountAll = CountAll + 1
            End If
        End If
    Next LWPLElem
    Set Ssobj(0) = Nothing
    If CountAll > 0 Then
        For Each LWPLElem In ObjctSset
            'ポリラインを±１でオフセットし面積で判定する
            On Error GoTo ERR2:
            OffsetObj1 = LWPLElem.Offset(1)
            OffsetObj2 = LWPLElem.Offset(-1)
            Area1 = OffsetObj1(0).Area
            Area2 = OffsetObj2(0).Area
            For I = LBound(OffsetObj1) To UBound(OffsetObj1)
                OffsetObj1(I).Delete
                OffsetObj2(I).Delete
            Next I
            On Error GoTo ERR:
            If Area1 > Area2 Then   '[>:時計回りに, <:逆時計回りに]
                If InversLWPolyline(LWPLElem) Then
                    Count = Count + 1
                Else
                    Error 51: Exit Sub
                End If
            ElseIf Area1 = Area2 Then
                Error 51: Exit Sub
            End If
        Next LWPLElem
        If Count > 0 Then
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline 全 " & CStr(CountAll) & " 個中 " & CStr(Count) & " 個 反転しました．"
        Else
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline  全 " & CStr(CountAll) & " 個中 " & "対象のライトウェイトポリラインはありませんでした．"
        End If
    Else
        ActiveDocument.Utility.Prompt vbCrLf & _
           "SetPolyline 対象のライトウェイトポリラインはありませんでした．"
    End If
Exit Sub
SSErr:
    ActiveDocument.SelectionSets.Item("LWPLSset").Delete
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    Resume Next
ERR2:
    For I = LBound(OffsetObj1) To UBound(OffsetObj1)
        OffsetObj1(I).Delete
        OffsetObj2(I).Delete
    Next I
ERR:
    Set Ssobj(0) = Nothing
    ActiveDocument.Utility.Prompt "*ERR(" & CStr(ERR.Number) & ")*"
End Sub
'ライトウェイトポリラインの始終点反転
'  反転可能プロパティ：座標順・各セグメントのふくらみ値と線幅
Public Function InversLWPolyline(LWPolylineObj As AcadLWPolyline) As Boolean
'　引数　ライトウェイトポリライン
'  戻値　正常終了 True
'  　　　エラー　 False　（コマンドラインにエラーNo）
Dim I           As Long
Dim N           As Long
Dim X           As Long     'Ｘ配列番号
Dim Y           As Long     'Ｙ配列番号
Dim CCount      As Long     '頂点の2D座標リスト添字の最大値
Dim Vertices    As Long     '頂点数
Dim Bulge()     As Double   'ふくらみ値リスト  (0 To Vertices - 1)
Dim SWidth()    As Double   'StartWidthリスト (0 To Vertices - 1)
Dim EWidth()    As Double   'EndWidthリスト   (0 To Vertices - 1)
Dim CoordinateX As Double   '仮格納 Ｘ座標値
Dim CoordinateY As Double   '仮格納 Ｙ座標値
Dim Coordinates As Variant  '各頂点の2D座標リスト (0 To CCount)
    On Error GoTo ERR:
    InversLWPolyline = False
    Coordinates = LWPolylineObj.Coordinates
    CCount = UBound(Coordinates)
    Vertices = (CCount + 1) / 2   '[1～
    ReDim Bulge(0 To Vertices - 1)
    ReDim SWidth(0 To Vertices - 1)
    ReDim EWidth(0 To Vertices - 1)
    N = Int(Vertices / 2) - 1
    '2D座標反転リスト作成
    For I = 0 To N
        X = I * 2 + 0
        Y = I * 2 + 1
        CoordinateX = Coordinates(X)
        CoordinateY = Coordinates(Y)
        Coordinates(X) = Coordinates(CCount - (X + 1))
        Coordinates(Y) = Coordinates(CCount - (Y - 1))
        Coordinates(CCount - (X + 1)) = CoordinateX
        Coordinates(CCount - (Y - 1)) = CoordinateY
    Next I
    '各セグメントのふくらみ値と線幅の反転リスト作成
    N = Vertices - 1
    '(1)始点～終点
    For I = 0 To N - 1
        Bulge(N - 1 - I) = -1 * LWPolylineObj.GetBulge(I)
        LWPolylineObj.GetWidth I, EWidth(N - 1 - I), SWidth(N - 1 - I)
    Next I
    '(2)最後（＝閉じている区間）は常にリストの最後
    Bulge(N) = -1 * LWPolylineObj.GetBulge(N)
    LWPolylineObj.GetWidth N, EWidth(N), SWidth(N)
    '各プロパティ変更（反転リストの適用）
    LWPolylineObj.Coordinates = Coordinates
    For I = 0 To Vertices - 1
        LWPolylineObj.SetBulge I, Bulge(I)
        LWPolylineObj.SetWidth I, SWidth(I), EWidth(I)
    Next I
    '終了処理
    LWPolylineObj.Update      '更新
    InversLWPolyline = True   '戻値セット
Exit Function
ERR:
    On Error Resume Next
    'コマンドラインにエラーNo
    ActiveDocument.Utility.Prompt "*エラー(" & ERR.Number & ")* "
    Exit Function
End Function

▼ サットン 2009/02/09(月) 15:03:57

著作権者の許可を得ていないため削除

▼ kamegai [HOMEPAGE] 2009/02/09(月) 15:29:45

＞Object was erased
「オブジェクトは削除された」ですか、、、

原因は解りませんが、とりあえずSetLWPolyline()を以下と取り替えてください。

'ライトウェイトポリラインの座標順を時計回りに（または反時計回りに）
Public Sub SetLWPolyline()
'  対象:ModelSpaceにある表示（アンフリーズ・アンロック）画層のライトウェイトポリライン
'       閉じている・いないは不問（ただし自身が交差する場合の結果は不定）
'  条件:時計回り・逆時計回りは、法線の座標系の平面図で判断します
Dim ObjctSset     As AcadSelectionSet
Dim Ssobj(0 To 0) As AcadEntity
Dim LWPLElem      As AcadEntity
Dim I             As Long
Dim Count         As Long
Dim CountAll      As Long
Dim Area1         As Double
Dim Area2         As Double
Dim OffsetObj1    As Variant
Dim OffsetObj2    As Variant
    On Error GoTo SSErr:
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    On Error GoTo ERR:
    Count = 0
    CountAll = 0
    'リスト作成
    For Each LWPLElem In ActiveDocument.ModelSpace
        If StrComp(TypeName(LWPLElem), "IAcadLWPolyline", 1) = 0 Then
            If ActiveDocument.Layers(LWPLElem.Layer).LayerOn And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Lock And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Freeze Then
                Set Ssobj(0) = LWPLElem
                ObjctSset.AddItems Ssobj
                CountAll = CountAll + 1
            End If
        End If
    Next LWPLElem
    Set Ssobj(0) = Nothing
    If CountAll > 0 Then
        For Each LWPLElem In ObjctSset
            'ポリラインを±１でオフセットし面積で判定する
            On Error GoTo ERR2:
            OffsetObj1 = LWPLElem.Offset(1)
            OffsetObj2 = LWPLElem.Offset(-1)
            If (Not IsEmpty(OffsetObj1)) And (Not IsEmpty(OffsetObj2)) Then
                Area1 = OffsetObj1(0).Area
                Area2 = OffsetObj2(0).Area
                For I = LBound(OffsetObj1) To UBound(OffsetObj1)
                    OffsetObj1(I).Delete
                    OffsetObj2(I).Delete
                Next I
                On Error GoTo ERR:
                If Area1 > Area2 Then   '[>:時計回りに, <:逆時計回りに]
                    If InversLWPolyline(LWPLElem) Then
                        Count = Count + 1
                    Else
                        Error 51: Exit Sub
                    End If
                ElseIf Area1 = Area2 Then
                    Error 51: Exit Sub
                End If
            ElseIf Area1 = Area2 Then
                Error 51: Exit Sub
            End If
            If Count Mod 20 = 0 Then
                DoEvents
            End If
        Next LWPLElem
        If Count > 0 Then
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline 全 " & CStr(CountAll) & " 個中 " & CStr(Count) & " 個 反転しました．"
        Else
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline  全 " & CStr(CountAll) & " 個中 " & "対象のライトウェイトポリラインはありませんでした．"
        End If
    Else
        ActiveDocument.Utility.Prompt vbCrLf & _
           "SetPolyline 対象のライトウェイトポリラインはありませんでした．"
    End If
Exit Sub
SSErr:
    ActiveDocument.SelectionSets.Item("LWPLSset").Delete
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    Resume Next
ERR2:
    If Not IsEmpty(OffsetObj1) Then
        For I = LBound(OffsetObj1) To UBound(OffsetObj1)
            OffsetObj1(I).Delete
        Next I
    End If
    If Not IsEmpty(OffsetObj2) Then
        For I = LBound(OffsetObj1) To UBound(OffsetObj1)
            OffsetObj2(I).Delete
        Next I
    End If
ERR:
    Set Ssobj(0) = Nothing
    ActiveDocument.Utility.Prompt "*ERR(" & CStr(ERR.Number) & ")*"
End Sub

▼ kamegai [HOMEPAGE] 2009/02/09(月) 15:31:59

訂正こちらで。

'ライトウェイトポリラインの座標順を時計回りに（または反時計回りに）
Public Sub SetLWPolyline()
'  対象:ModelSpaceにある表示（アンフリーズ・アンロック）画層のライトウェイトポリライン
'       閉じている・いないは不問（ただし自身が交差する場合の結果は不定）
'  条件:時計回り・逆時計回りは、法線の座標系の平面図で判断します
Dim ObjctSset     As AcadSelectionSet
Dim Ssobj(0 To 0) As AcadEntity
Dim LWPLElem      As AcadEntity
Dim I             As Long
Dim Count         As Long
Dim CountAll      As Long
Dim Area1         As Double
Dim Area2         As Double
Dim OffsetObj1    As Variant
Dim OffsetObj2    As Variant
    On Error GoTo SSErr:
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    On Error GoTo ERR:
    Count = 0
    CountAll = 0
    'リスト作成
    For Each LWPLElem In ActiveDocument.ModelSpace
        If StrComp(TypeName(LWPLElem), "IAcadLWPolyline", 1) = 0 Then
            If ActiveDocument.Layers(LWPLElem.Layer).LayerOn And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Lock And _
               Not ActiveDocument.Layers(LWPLElem.Layer).Freeze Then
                Set Ssobj(0) = LWPLElem
                ObjctSset.AddItems Ssobj
                CountAll = CountAll + 1
            End If
        End If
    Next LWPLElem
    Set Ssobj(0) = Nothing
    If CountAll > 0 Then
        For Each LWPLElem In ObjctSset
            'ポリラインを±１でオフセットし面積で判定する
            On Error GoTo ERR2:
            OffsetObj1 = LWPLElem.Offset(1)
            OffsetObj2 = LWPLElem.Offset(-1)
            If (Not IsEmpty(OffsetObj1)) And (Not IsEmpty(OffsetObj2)) Then
                Area1 = OffsetObj1(0).Area
                Area2 = OffsetObj2(0).Area
                For I = LBound(OffsetObj1) To UBound(OffsetObj1)
                    OffsetObj1(I).Delete
                    OffsetObj2(I).Delete
                Next I
                On Error GoTo ERR:
                If Area1 > Area2 Then   '[>:時計回りに, <:逆時計回りに]
                    If InversLWPolyline(LWPLElem) Then
                        Count = Count + 1
                    Else
                        Error 51: Exit Sub
                    End If
                ElseIf Area1 = Area2 Then
                    Error 51: Exit Sub
                End If
            Else
                Error 51: Exit Sub
            End If
            If Count Mod 20 = 0 Then
                DoEvents
            End If
        Next LWPLElem
        If Count > 0 Then
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline 全 " & CStr(CountAll) & " 個中 " & CStr(Count) & " 個 反転しました．"
        Else
            ActiveDocument.Utility.Prompt vbCrLf & _
               "SetPolyline  全 " & CStr(CountAll) & " 個中 " & "対象のライトウェイトポリラインはありませんでした．"
        End If
    Else
        ActiveDocument.Utility.Prompt vbCrLf & _
           "SetPolyline 対象のライトウェイトポリラインはありませんでした．"
    End If
Exit Sub
SSErr:
    ActiveDocument.SelectionSets.Item("LWPLSset").Delete
    Set ObjctSset = ActiveDocument.SelectionSets.Add("LWPLSset")
    Resume Next
ERR2:
    If Not IsEmpty(OffsetObj1) Then
        For I = LBound(OffsetObj1) To UBound(OffsetObj1)
            OffsetObj1(I).Delete
        Next I
    End If
    If Not IsEmpty(OffsetObj2) Then
        For I = LBound(OffsetObj1) To UBound(OffsetObj1)
            OffsetObj2(I).Delete
        Next I
    End If
ERR:
    Set Ssobj(0) = Nothing
    ActiveDocument.Utility.Prompt "*ERR(" & CStr(ERR.Number) & ")*"
End Sub

▼ kamegai [HOMEPAGE] 2009/02/09(月) 15:36:43

おっと、さらに訂正。。。何度もすいません。

ERR2:の２つ目
誤：For I = LBound(OffsetObj1) To UBound(OffsetObj1)
正：For I = LBound(OffsetObj2) To UBound(OffsetObj2)

▼ サットン 2009/02/09(月) 15:45:45