| このページについて | ||||||||||||||||||||||||||
|
このページは、mura's home の AutoCAD掲示板 で、当方の発言（書込み）がある以下の掲示板の内容です。
タイトルおよび質問内容は上記より引用しています。 引用した質問内容は、バックカラーが となっています。 当方の発言は、バックカラーが となっています。 その他の著作権者の掲載許可を得ていない発言内容は削除（リンクを除く）しています。 また、当方では、削除部分の正当な著作権保持者を判断出来ませんので、 ご連絡を頂いても、復活させることは出来ません。ご了承下さい。
|
||||||||||||||||||||||||||
いつも勉強させていただいています。
VBAでポリラインと他のオブジェクトを選択して、交点が
あれば、その交点までのポリライン上の距離を測りたいと
思っています。
ポリラインには線分だけではなく、円弧とかも入ってい
ます。
いろいろを調べたところ、IntersectWithを使えば交点の
座標が取得できることはわかったのですが、その交点ま
での距離をどうやって取得してよいのかが解りません。
交点がどことどこの中間点の間にあるかわかれば、そこ
までの距離を地道に計算させればよいようにも思えます
が、何か良い方法はないでしょうか。
ご存知の方お教え下さい。
よろしくお願いいたします。
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
著作権者の許可を得ていないため削除
秘策公開と云うわけではありませんが、少し特殊な方法です。
VBAに曲線計測関数が搭載されていないので、
拡張AutoLISP関数（曲線計測関数等）を使用して求めています。
開発・動作確認は2000i、他のバージョンは動作未確認です。
取り急ぎ貼り付けのみ、長文失礼。
Option Explicit
' 開発・動作確認 2000i
'
Public Sub Test()
' O Snap の設定を変更するので注意
Dim SelectObj As AcadObject
Dim LWPLLength As Variant '[Double]
Dim PickPoint As Variant
On Error Resume Next
ActiveDocument.Utility.GetEntity SelectObj, PickPoint, vbLf & "ライトウェイトポリラインを選択: "
If ERR Then
'エラー
ERR.Clear
ActiveDocument.Utility.Prompt vbLf & "*選択エラー* "
Exit Sub
End
ElseIf Not TypeName(SelectObj) = "IAcadLWPolyline" Then
'ライトウェイトポリライン以外を選択
ActiveDocument.Utility.Prompt vbLf & "*ライトウェイトポリラインではありません* "
Exit Sub
End
Else
On Error GoTo ERR:
PickPoint = Empty
ActiveDocument.ObjectSnapMode = True
ActiveDocument.SendCommand "-osnap" & vbCr & "_nea,_endp" & vbCr
'点を取得
On Error GoTo ERR2:
PickPoint = ActiveDocument.Utility.GetPoint(, vbLf & "点を指示: ")
On Error GoTo ERR:
End If
LWPLLength = BreakPoint_LWPolylineLengthByVBA(SelectObj, PickPoint)
If LWPLLength = 0 Then
'始点or不明点
Dim ObjectCoordinates() As Double
ObjectCoordinates = SelectObj.Coordinates
If ObjectCoordinates(0) = PickPoint(0) And ObjectCoordinates(1) = PickPoint(1) And SelectObj.Elevation = PickPoint(2) Then
'始点が指示された
Else
'不明点
LWPLLength = Empty
ActiveDocument.Utility.Prompt vbLf & "*切断点が線上にありません* "
End If
Else
End If
If IsEmpty(LWPLLength) Then
MsgBox "長さ取得に失敗"
Else
MsgBox "長さ = " & CStr(LWPLLength)
End If
Exit Sub
End
ERR2:
ActiveDocument.Utility.Prompt vbLf & "*キャンセル* "
Exit Sub
End
ERR:
ActiveDocument.Utility.Prompt vbLf & "*エラー(" & ERR.Number & ")* "
Exit Sub
End
Resume Next
End Sub
'
Private Function BreakPoint_LWPolylineLengthByVBA(SelectObj As AcadObject, BreakPoint As Variant) As Variant
'BreakPoint_LWPolylineLengthByVBA Ver.0.01 α版 Akinori Kamegai (C) 2007
'始点から指示点までのライトウェイトポリラインの長さ取得する関数
' システム変数 USERS1 を使用
' コマンドラインからAutoLISPを使用
'戻り値 正常終了 長さ [Variant/Double]
' 異常終了 Empty [Variant/Empty]
' BreakPoint(0):X
' BreakPoint(1):Y
' BreakPoint(2):Z
Dim MyPos As Long
Dim TmpLength As Double
Dim ComStr As String
Dim TMPStr As String
Dim SearchChar As String
Dim SearchString As String
Dim BPLWPLBVBA As String
On Error GoTo ERR:
BPLWPLBVBA = "USERS1" 'AutoCAD システム変数
If Not TypeName(SelectObj) = "IAcadLWPolyline" Then
Exit Function
Else
'拡張 AutoLISP 関数を使用できるようにする
ActiveDocument.SendCommand "(vl-load-com)" & vbCr & Chr(3)
'送信するLISPコマンド作成
ComStr = ""
ComStr = ComStr & "(setvar """ & BPLWPLBVBA & """ " 'AutoCAD システム変数 "USERS1" に代入
ComStr = ComStr & "(vl-princ-to-string " 'LISP データを表す文字列を、princ 関数で出力したかのように返す
ComStr = ComStr & "(vlax-variant-change-type " 'あるデータ タイプから別のデータ タイプに変更したバリアント型の値を返す
ComStr = ComStr & "(vlax-make-variant " 'バリアント型データ タイプを作成
ComStr = ComStr & "(vlax-curve-getDistAtPoint " '曲線の始点から指定された点までの曲線のセグメントの長さを返す
ComStr = ComStr & "(vlax-ename->vla-object " '図形名を VLA オブジェクトに変換
ComStr = ComStr & "(handent " 'ハンドル番号に基づいて、オブジェクト(図形)名を返す
ComStr = ComStr & Chr(34) & SelectObj.Handle & Chr(34) & ")) " 'ハンドル番号
ComStr = ComStr & "'(" '3D 点リスト(WCS)
ComStr = ComStr & CStr(BreakPoint(0)) & " " ' X
ComStr = ComStr & CStr(BreakPoint(1)) & " " ' Y
ComStr = ComStr & CStr(BreakPoint(2)) & ")) " ' Z
ComStr = ComStr & "vlax-vbDouble) " '（バリアント型の）倍精度浮動小数点数
ComStr = ComStr & "vlax-vbString)))" & vbCr '文字列
'-----戻り値 成功した場合はシステム変数に文字列
'----- 例 "#<variant 8 365.882575838713>"
ActiveDocument.SendCommand ComStr
'[キャンセル/ESC]を２回送信
ActiveDocument.SendCommand Chr(3) & Chr(3)
TMPStr = CStr(ActiveDocument.GetVariable(BPLWPLBVBA))
'長さ取得
SearchString = TMPStr
SearchChar = "#"
MyPos = InStr(1, SearchString, SearchChar, 1)
If MyPos = 0 Then
ActiveDocument.Utility.Prompt vbLf & "*長さ取得エラー* "
Exit Function
End If
SearchString = TMPStr
SearchChar = " "
MyPos = InStr(MyPos, SearchString, SearchChar, 1)
MyPos = InStr(1 + MyPos, SearchString, SearchChar, 1)
TMPStr = Mid(TMPStr, MyPos + 1)
SearchString = TMPStr
SearchChar = ">"
MyPos = InStr(1, SearchString, SearchChar, 1)
TMPStr = Left(TMPStr, MyPos - 1)
TmpLength = CDbl(TMPStr)
End If
BreakPoint_LWPolylineLengthByVBA = TmpLength
Exit Function
End
ERR:
ActiveDocument.Utility.Prompt vbLf & "*エラー(" & ERR.Number & ")* "
Exit Function
End
Resume Next
End Function
|
著作権者の許可を得ていないため削除
＞2007でも問題なく動きました。
とりあえず一安心（笑）
上記に書き込んだVBAは、
お題の”VBAでポリラインの途中の点までの距離を測りたい”用にあわせて
簡単に確認できるようにしたものです。
＞ポリラインの始点からオブジェクト上の点までの距離が一発で取得
＞できるということで良いでしょうか。
＞これであればどことどこの頂点の間とかを考えなくてすむというこ
＞とでしょうか。
そうです。
任意の２点間であれば２回実行してその差を求めればいいこととなります。
ただし、エラー処理は考慮していませんので別途追加の必要があるかもしれません。
ちなみに、下記で紹介している汎用関数であれば、ポリライン以外でもＯＫです。
作動させた後にテキストウインドウをご覧頂くと分かりますが、
VBAから直接AutoLISPを実行できないので、SendCommand経由で
コマンドラインからAutoLISP関数へアクセスしています。
また、確実にAutoLISP関数の戻り値を取得するために、
上記のVBAでは、システム変数"USERS1"を使用しています。
他のプログラムとバッディングしないようにご注意下さい。
＞vbaで円弧を含むポリラインの長さを取得するより便利そうです。
確かに便利ですが、少し（というかかなり）特殊な方法です。
VBAにもAutoLISP同等の曲線計測関数を搭載していただけると助かるのですが。
自動机さんお願いします。
汎用的に使用できる関数を以下で紹介しましたのでご覧下さい。
http://www.mura.sh/bbs/wwwbbs.cgi?print+200705/07050106.txt
良いことだけではありません、デメリットもあります。
SendCommand経由でのコマンドラインからAutoLISP関数へアクセスは、
処理速度がとても遅いです。
大量に繰り返し処理が必要ならば、
VBAではなく最初からAutoLISPでプログラムした方がよいでしょう。
例えるなら、
２階へ本を取りに行くのに、大家（自動机さん）が階段を作り忘れた？ので
玄関から外に出て梯子をかけて２階の窓から入るようなのもです。
帰りももちろん梯子を降りて戻ります（笑）
著作権者の許可を得ていないため削除
＞繰り返し処理は多くても1000回もいかないと思うので、とりあえず
当方の環境では100回で１秒弱、1000回で10秒弱なら我慢の範囲内でしょうか？
念のため・・・
上記のVBAでは、「拡張
AutoLISP 関数を使用できるようにする」の
ActiveDocument.SendCommand "(vl-load-com)" &
vbCr &
Chr(3)
を、（Function部のみコピーされてもエラーにならないように）Function内に書き込んでありますが、
これは１回実行（呼び出せば）充分なので、繰り返し処理が大量ならば、
メインSUB内で１回実行するように変更してください。
当方の環境では1000回で1秒ほどの短縮ですが（笑）
さらに同様にFunction内の
'[キャンセル/ESC]を２回送信
ActiveDocument.SendCommand
Chr(3) & Chr(3)
を消せば、当方の環境で1000回で3秒ほどの短縮出来ます（笑）