| Random Thoughts |
| In a crisis call for Isis!
|
| 言語 |
|
|
|
| フォーラムニュース: 質問、相談カテゴリに「SolidWorks操作方法」に関するフォーラムを追加しました。(2003/11/27) |
| いらっしゃい、 ゲストさん. まずはこちら→ ログイン または 登録. 2024/11/27 - 09:52:53 |
|
     |
|
著者
|
トピック: 部品原点を合致・スケッチ拘束で使用する[VBA] (閲覧数 3706 回) |
|
hisa
カタマリの王様!?
 オフライン
投稿: 507
PANDA-Z!!
 
|
 |
部品原点を合致・スケッチ拘束で使用する[VBA]
« 投稿日: 2007/05/14 - 18:52:35 » |
 |
こんにちはhisaです 
ふと思い立ったので投稿します 
APIで、部品原点を合致やスケッチ拘束で使用する場合、単に原点のFeatureを取得して
選択するだけでは、ウマくいきません。
厳密には、原点の内部的に存在するスケッチ点を選択することで可能となります。
SelectByID2等で選択する手もありますが、Assembly上の構成部品が対象の場合、
名前の解決が結構面倒です。
ですので、以下に構成部品(Component2)から原点内スケッチ点を取得するサンプルを
示します。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2
Dim swCompFeat As SldWorks.Feature
Dim swPoint As Variant
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swSelMgr = swModel.SelectionManager
Set swComp = swSelMgr.GetSelectedObjectsComponent2(1)
'Case(1)：Feature名が"原点"と限定されている場合
Set swCompFeat = swComp.FeatureByName("原点")
If swCompFeat.GetTypeName = "OriginProfileFeature" Then
Set swCompFeat = swCompFeat.GetSpecificFeature2
swPoint = swCompFeat.GetSketchPoints2
swPoint(0).Select4 False, Nothing
End If
'Case(1)：End
'Case(2)：Feature名が"原点"と限定されていない場合
Set swCompFeat = swComp.FirstFeature
While Not swCompFeat Is Nothing
If swCompFeat.GetTypeName = "OriginProfileFeature" Then
Set swCompFeat = swCompFeat.GetSpecificFeature2
swPoint = swCompFeat.GetSketchPoints2
swPoint(0).Select4 False, Nothing
End If
Wend
'Case(2)：End
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Case1は、Feature名が"原点"と特定されている場合のCodeです。
Case2は、Feature名が"原点"と特定されていない場合のCodeです。
場合によって使い分けてください。
ユーザーが任意に変えられる情報なので、Case2をお勧めですが…
以上、ご参考まで。
|
|
|
|
|
hisa
カタマリの王様!?
オフライン
投稿: 507
PANDA-Z!!
|
|
Re:部品原点を合致・スケッチ拘束で使用する[VBA]
« 返信 #1 投稿日: 2007/08/09 - 17:36:15 » |
|
久々にトピックスを読み返していたら、恐ろしい間違いを発見しました 
Case2のコードが、無限ループしてしまっています 
While Not swCompFeat Is Nothing
If swCompFeat.GetTypeName = "OriginProfileFeature" Then
Set swCompFeat = swCompFeat.GetSpecificFeature2
swPoint = swCompFeat.GetSketchPoints2
swPoint(0).Select4 False, Nothing
End If
Set swCompFeat = swCompFeat.GetNextFeature
Wend
上記赤文字の行を追加しないといけませんでしたね…
誠に申し訳ありませんでした･･･m(__)m
|
|
|
|
|
|
|
|
|
記録済み