| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
断面図を編集しているのですが、ポリラインの方向が左から右へという作りじゃないとだめだといわれました。
他社からの引継ぎで、最初から作業しているものでないので、ポリラインが右向きだったり左向きだったりしているのです。
指定のレイヤーに入っているポリラインを左から右へ一括で変更することはできるのでしょうか？
アドバイスよろしくお願いします。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
http://www.mura.sh/bbs/wwwbbs.cgi?print+200703/07030027.txt
著作権者の許可を得ていないため削除
では、私はVBAで・・・
ライトウェイトポリラインの始終点反転の関数とサンプルプログラムです。
http://www.mura.sh/bbs/wwwbbs.cgi?print+200705/07050072.txt
のBreak4LWPlineで使用していた同様関数のバージョンアップ版です。
特徴・・・ハンドルは保持した状態で変更
＞LISP・VBAは初めてなので・・・
とのことなので追加の説明をします。
ライトウェイトポリライン専用、一括で変更ではなくて、
個別に逐一選択確認バージョンです。
反転可能なプロパティは、座標順と各セグメントのふくらみ値と線幅。
プログラムを使用する手順。
1.[ツール]-[マクロ]-[VBA管理]で新規作成。
2.[ツール]-[マクロ]-[Visual
Basic
エディタ]で統合開発環境(IDE)へ
3.新規作成されたプロジェクトを選択して[挿入]-[標準モジュール]
4.追加された標準モジュール"Module1"をクリックしして開き、
下記プログラムを貼付
5.AutoCADに戻り[ツール]-[マクロ]-[VBA管理]で”名前を付けて保存”
次回起動時はこのファイルを[ツール]-[マクロ]-[プロジェクトロード]で読み込みます
6.[ツール]-[マクロ]-[マクロ]でExample_InversLWPolylineを選択して実行します
頻繁に使用するならメニューボタンに
^C^C-vbarun;Example_InversLWPolyline^M
と登録してください。
●注意事項
点スタイルを一時的に変更、正常終了時に元に戻していますので、
異常終了時には手動で戻してください
不具合あれば書き込んでください。長文失礼。
Option Explicit
'
'ライトウェイトポリラインの始終点反転
' 反転可能プロパティ：座標順・各セグメントのふくらみ値と線幅
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
'ライトウェイト ポリラインの始終点を反転するサンプルプログラム
Public Sub Example_InversLWPolyline()
Dim returnObj As AcadObject
Dim pointObj As AcadPoint
Dim Str As String
Dim Title As String
Dim Style As Integer
Dim CurrentPDMODE As Integer
Dim Response As Long
Dim Point(0 To 2) As Double
Dim basePnt As Variant
Dim Coordinates As Variant
On Error GoTo ERR:
'点スタイルを記憶
CurrentPDMODE = ThisDrawing.GetVariable("PDMODE")
'点スタイルをＸにする
ThisDrawing.SetVariable "PDMODE", 3
SELECTERR:
Title = "ライトウェイトポリラインを反転"
Str = "ライトウェイトポリラインを選択してください " & vbCrLf
Style = vbOKCancel + vbInformation
Response = MsgBox(Str, Style, Title)
If Response = vbOK Then
NEXTSELECT:
On Error Resume Next
ActiveDocument.Utility.GetEntity returnObj, basePnt, vbCr & "ライトウェイトポリラインを選択してください: "
If ERR Then
On Error GoTo ERR:
GoTo SELECTERR:
Else
On Error GoTo ERR:
If TypeName(returnObj) = "IAcadLWPolyline" Then
If Not ActiveDocument.Layers(returnObj.Layer).Lock Then
RETRAY:
'始点に点を作成（処理を確認できます）
Coordinates = returnObj.Coordinates
Point(0) = CDbl(Coordinates(0))
Point(1) = CDbl(Coordinates(1))
Point(2) = returnObj.Elevation
Set pointObj = ThisDrawing.ModelSpace.AddPoint(Point)
pointObj.Color = acRed
pointObj.Update
Str = "" & vbCrLf
Str = Str & "反転しますか？ （赤点が始点位置です） " & vbCrLf & vbCrLf
Str = Str & "" & vbCrLf
Str = Str & "はい：反転 ／ いいえ：終了 ／ キャンセル：次を選択 " & vbCrLf & vbCrLf
Style = vbYesNoCancel + vbInformation
Response = MsgBox(Str, Style, Title)
If Response = vbYes Then
If InversLWPolyline(returnObj) Then
'点を移動
Erase Coordinates
Coordinates = returnObj.Coordinates
Point(0) = CDbl(Coordinates(0))
Point(1) = CDbl(Coordinates(1))
Point(2) = returnObj.Elevation
pointObj.Coordinates = Point
pointObj.Update
Str = "ライトウェイトポリラインの始終点を反転しました。 " & vbCrLf & vbCrLf
Str = Str & "次のライトウェイトポリラインを選択しますか？ " & vbCrLf & vbCrLf
Style = vbYesNo + vbInformation
Else
Str = "ライトウェイトポリライン反転に失敗しました。 " & vbCrLf & vbCrLf
Str = Str & "次のライトウェイトポリラインを選択しますか？ " & vbCrLf & vbCrLf
Str = Str & "（無視で次のライトウェイトポリラインを選択） " & vbCrLf & vbCrLf
Style = vbAbortRetryIgnore + vbQuestion
End If
Response = MsgBox(Str, Style, Title)
If Response = vbYes Then 'はい
pointObj.Delete
GoTo NEXTSELECT:
ElseIf Response = vbNo Then 'いいえ
ElseIf Response = vbAbort Then '中止
ElseIf Response = vbIgnore Then '無視
pointObj.Delete
GoTo NEXTSELECT:
ElseIf Response = vbRetry Then '再試行
pointObj.Delete
GoTo RETRAY:
End If
ElseIf Response = vbCancel Then
pointObj.Delete
GoTo NEXTSELECT:
End If
pointObj.Delete
On Error GoTo ERR:
Else
Str = "ロック画層にあります " & vbCrLf
Style = vbOKOnly + vbInformation
Response = MsgBox(Str, Style, Title)
GoTo SELECTERR:
End If
Else
Str = "ライトウェイトポリラインではありません " & vbCrLf
Str = Str & "ライトウェイトポリラインを選択してください " & vbCrLf
GoTo SELECTERR:
End If
End If
End If
'点スタイルを復元
ThisDrawing.SetVariable "PDMODE", CurrentPDMODE
End
ERR:
On Error Resume Next
If Not pointObj Is Nothing Then pointObj.Delete
'点スタイルを復元
ThisDrawing.SetVariable "PDMODE", CurrentPDMODE
End Sub |
著作権者の許可を得ていないため削除
＞ポリラインの方向が左から右へという作りじゃないとだめだといわれました。
反転の条件は単純に、「始点のＸ座標値＞終点のＸ座標値
の場合の反転する」として、
下記のプログラムを上記の下に貼り付け、「LayerName =
"0"」を
指定レイヤー名に変更してください。
エラー無き場合は、サイレントに処理が終了します。
'ライトウェイト ポリラインの始終点を反転するサンプルプログラム２
Public Sub Example2_InversLWPolyline()
Dim obj As AcadObject
Dim LayerName As String
Dim Coordinates As Variant
On Error GoTo ERR:
LayerName = "0"
For Each obj In ActiveDocument.ModelSpace
If TypeName(obj) = "IAcadLWPolyline" Then
If obj.Layer = LayerName Then
Coordinates = obj.Coordinates
If Coordinates(0) > Coordinates(UBound(Coordinates) - 1) Then
If Not InversLWPolyline(obj) Then
MsgBox "InversLWPolylineエラー", vbOKOnly + vbCritical, "Example2"
Exit Sub
End If
End If
End If
End If
Next
Exit Sub
ERR:
MsgBox "Exampleエラー", vbOKOnly + vbCritical, "Example2"
End Sub |
著作権者の許可を得ていないため削除
＞この下に付け加えるのでしょうか？
え〜と、説明が不十分でしたか。
最後の最後
の下に付け加えてください。
そうすれば、
法面などの囲み方向の修正は「Example_InversLWPolyline」
指定レイヤー一括処理は「Example2_InversLWPolyline」
の両方利用できます。
＃「LayerName = "0"」の修正を確認してください。
念のため・・・
最後の最後に付け加えたら、
指定レイヤー一括処理は、
[ツール]-[マクロ]-[マクロ]で"Example2_InversLWPolyline"
を選択して実行します。
"Example_InversLWPolyline"と
"Example2_InversLWPolyline"が表示されるので、
"2"のある方を選択してください。
または、メニューボタンに登録して使用しているのであれば、
^C^C-vbarun;Example_InversLWPolyline^M
↓
^C^C-vbarun;Example2_InversLWPolyline^M
に登録変更してください。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
ゆきちさん、お役に立ったようで安心致しました。
ちえちゃんさんへ。
＞指定レイヤが多数ある場合はどうしたらよいでしょうか？
とのことなので、表示オンでロックとフリーズされていない画層の
ライトウェイトポリラインをすべて一括処理します。
処理から除外したい画層は非表示（またはロック・フリーズ）にして下さい。
サイレント処理では味気ないので、処理数を表示するようにしました。
前回同様、最後の最後に付け加えたら、
"Example3_InversLWPolyline"を選択して実行してください。
'ライトウェイト ポリラインの始終点を反転するサンプルプログラム３
' 対象：表示オン＆ロック・フリーズされていない画層のLWPolyline
Public Sub Example3_InversLWPolyline()
Dim obj As AcadObject
Dim Count As Long
Dim CountAll As Long
Dim Coordinates As Variant
On Error GoTo ERR:
Count = 0
CountAll = 0
For Each obj In ActiveDocument.ModelSpace
If TypeName(obj) = "IAcadLWPolyline" Then
If ActiveDocument.Layers(obj.Layer).LayerOn And _
Not ActiveDocument.Layers(obj.Layer).Lock And _
Not ActiveDocument.Layers(obj.Layer).Freeze Then
CountAll = CountAll + 1
Coordinates = obj.Coordinates
If Coordinates(0) > Coordinates(UBound(Coordinates) - 1) Then
If InversLWPolyline(obj) Then
Count = Count + 1
Else
MsgBox "InversLWPolylineエラー", vbOKOnly + vbCritical, "Example3"
Exit Sub
End If
End If
End If
End If
Next
If Count > 0 Then
ActiveDocument.Utility.Prompt vbCrLf & _
"InversLWPolyline 全 " & CStr(CountAll) & " 個中 " & CStr(Count) & " 個 反転しました．"
Else
ActiveDocument.Utility.Prompt vbCrLf & _
"InversLWPolyline 対象のライトウェイトポリラインはありませんでした．"
End If
Beep
Exit Sub
ERR:
MsgBox "Exampleエラー", vbOKOnly + vbCritical, "Example3"
End Sub |
著作権者の許可を得ていないため削除