2017-06-05

Viewpoint3Dで表示を動かす2

CATIA_V5 VBA

こちらのｺﾒﾝﾄで御質問頂いた "画面中心に表示させる"
方法のｻﾝﾌﾟﾙです。
ｸﾘｯｸした面に法線を作成する - C#ATIA

と言っても、過去にﾃｽﾄしたｺｰﾄﾞを64bitで動くように
修正しただけなのですが･･･
Viewpoint3Dで表示を動かす - C#ATIA

'vba test_Viewpoint3D ver0.0.2
'3Dｶﾒﾗのﾃｽﾄ

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private Const DefaultSpeed = 5000

Sub CATMain()
    Dim Msg$
    Dim Filter As Variant: Filter = Array("AnyObject")
    
    'ｽﾀｰﾄView
    Msg = "開始するﾋﾞｭｰの状態しに、何かｸﾘｯｸしてください(ESC/中止)"
    If IsNothing(SelectItem(Msg, Filter)) Then Exit Sub
    Dim StartScene As Variant: StartScene = GetScene3D(GetViewPnt3D())
    
    'ｴﾝﾄﾞView
    Msg = "終了するﾋﾞｭｰの状態しに、何かｸﾘｯｸしてください(ESC/中止)"
    If IsNothing(SelectItem(Msg, Filter)) Then Exit Sub
    Dim EndScene As Variant: EndScene = GetScene3D(GetViewPnt3D())
    
    'ｱﾆﾒｰｼｮﾝ開始
    Call UpdateScene(StartScene)
    Dim SceneSpeed&
    Dim IptSpeed As Variant: IptSpeed = DefaultSpeed
    Msg = "再生を開始します(再生中ESCｷｰでｽﾋﾟｰﾄﾞ再設定)" + vbNewLine _
        + "再生ｽﾋﾟｰﾄﾞを半角数字で入力して下さい" + vbNewLine _
        + "(大きいほど遅いです / 0以下 - 終了)"
    Do
        IptSpeed = InputBox(Msg, , IptSpeed)
        If Not IsNumeric(IptSpeed) Then Exit Do
        SceneSpeed = CLng(IptSpeed)
        If SceneSpeed <= 0 Then Exit Do
        
        Call ShowAnimation(StartScene, EndScene, SceneSpeed)
    Loop
End Sub

'表示開始
Private Sub ShowAnimation(ByVal SScene As Variant, ByVal EScene As Variant, ByVal Speed&)
    '情報取得
    Dim AryCount&: AryCount = UBound(SScene)
    
    '増分
    Dim i&
    Dim Step() As Variant: ReDim Step(AryCount)
    For i = 0 To AryCount
        Step(i) = (EScene(i) - SScene(i)) / Speed
    Next
    
    '更新
    Dim j&
    Dim state() As Variant: ReDim state(AryCount)
    For i = 0 To Speed
        For j = 0 To AryCount
            state(j) = SScene(j) + (Step(j) * i)
        Next
        If CheckEvents Then 'ESCｷｰ
            Call UpdateScene(SScene)
            Exit For
        End If
        Call UpdateScene(state)
    Next
End Sub

'ESCｷｰ判定 -WinAPI GetInputState関数が機能しない
Private Function CheckEvents() As Boolean
    DoEvents
    CheckEvents = GetAsyncKeyState(vbKeyEscape)
End Function

'表示のUpdate
Private Sub UpdateScene(ByVal Scene As Variant)
    Dim Viewer As Viewer3D: Set Viewer = CATIA.ActiveWindow.ActiveViewer
    Dim VPnt3D As Variant 'Viewpoint3D '
    Set VPnt3D = Viewer.Viewpoint3D
    
    Dim Ary As Variant
    Ary = GetRangeAry(Scene, 0, 2)
    Call VPnt3D.PutOrigin(Ary)
    
    Ary = GetRangeAry(Scene, 3, 5)
    Call VPnt3D.PutSightDirection(Ary)
    
    Ary = GetRangeAry(Scene, 6, 8)
    Call VPnt3D.PutUpDirection(Ary)
    
    VPnt3D.FieldOfView = Scene(9)
    VPnt3D.FocusDistance = Scene(10)
    
    Call Viewer.Update
End Sub

'Viewpoint3Dからｼｰﾝ取得
Private Function GetScene3D(ViewPnt3D As Viewpoint3D) As Variant
    Dim vp As Variant: Set vp = ViewPnt3D
    
    Dim origin(2) As Variant: Call vp.GetOrigin(origin)
    
    Dim sight(2) As Variant: Call vp.GetSightDirection(sight)
    GetScene3D = JoinArray(origin, sight)
    
    Dim up(2) As Variant: Call vp.GetUpDirection(up)
    GetScene3D = JoinArray(GetScene3D, up)
    
    Dim FieldOfView(0) As Variant: FieldOfView(0) = vp.FieldOfView
    GetScene3D = JoinArray(GetScene3D, FieldOfView)
    
    Dim FocusDist(0) As Variant: FocusDist(0) = vp.FocusDistance
    GetScene3D = JoinArray(GetScene3D, FocusDist)
End Function

'現状の視点取得
Private Function GetViewPnt3D() As Viewpoint3D
    Set GetViewPnt3D = CATIA.ActiveWindow.ActiveViewer.Viewpoint3D
End Function

'選択
Private Function SelectItem(ByVal Msg$, ByVal Filter As Variant) As AnyObject
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectItem = Sel.Item(1).Value
    Sel.Clear
End Function

'Nothing 書き方に統一感が無い為
Private Function IsNothing(ByVal OJ As Variant) As Boolean
    IsNothing = OJ Is Nothing
End Function

'配列の連結
Private Function JoinArray(ByVal Ary1 As Variant, ByVal Ary2 As Variant)
    If Not IsArray(Ary1) Or Not IsArray(Ary2) Then Exit Function
    Dim StCount&: StCount = UBound(Ary1)
    ReDim Preserve Ary1(UBound(Ary1) + UBound(Ary2) + 1)
    Dim i&
    For i = StCount + 1 To UBound(Ary1)
        Ary1(i) = Ary2(i - StCount - 1)
    Next
    JoinArray = Ary1
End Function

'配列の抽出
Private Function GetRangeAry(ByVal Ary As Variant, StartIdx&, ByVal EndIdx&) As Variant
    If Not IsArray(Ary) Then Exit Function
    If EndIdx - StartIdx < 0 Then Exit Function
    If StartIdx < 0 Then Exit Function
    If EndIdx > UBound(Ary) Then Exit Function
    
    Dim RngAry() As Variant: ReDim RngAry(EndIdx - StartIdx)
    Dim i&
    For i = StartIdx To EndIdx
        RngAry(i - StartIdx) = Ary(i)
    Next
    GetRangeAry = RngAry
End Function

Viewer3Dｸﾗｽ内のViewpoint3Dﾌﾟﾛﾊﾟﾃｨを操作することになります。
正確に細かな事はわかっておりませんが
・中心となる座標値
・向く方向の3Dﾍﾞｸﾄﾙ
・上方向となる3Dﾍﾞｸﾄﾙ
を調整する事で上記のﾏｸﾛを実行しています。

このﾏｸﾛ自体が役立つとは思えませんが、実際に実行した際は
このような感じになります。

2017-06-02

読み取り専用でﾌｧｲﾙを開く2

CATIA_V5 VBA

昨日、imihitoさんからのｱﾄﾞﾊﾞｲｽを利用するために書き換えてみました。
読み取り専用でﾌｧｲﾙを開く1 - C#ATIA

VBA.FileSystem.SetAttr/GetAttr関数を利用して進めていたのですが、
ﾌｧｲﾙの存在をﾁｪｯｸや拡張子を取得する関数類がVBA.FileSystemには
存在していないようなので、結局FileSystemObjectを利用し、
(文句を書いた)VBA.VbFileAttribute列挙型のみを利用しました。

'vba sample_FileOpen_ReadOnly_ver0.0.2
'読み取り専用でCATIAなﾌｧｲﾙを読み込む

Option Explicit

Sub CATMain()
    'ﾌｧｲﾙ選択
    Dim OpenFilePath As String
    Dim Msg As String: Msg = "読み取り専用で開くﾌｧｲﾙを選択してください"
    OpenFilePath = CATIA.FileSelectionBox(Msg, "*.CAT*", CatFileSelectionModeOpen)
    If OpenFilePath = vbNullString Then Exit Sub
    
    'ﾌｧｲﾙを開く
    Call CatOpen_ReadOnly(OpenFilePath)
End Sub

'読み取り専用で開く
''' @param:Path(string) ﾌｧｲﾙﾊﾟｽ
''' @return:Boolean True-成功　False-失敗
Private Function CatOpen_ReadOnly(ByVal Path As String) As Boolean
    CatOpen_ReadOnly = False
    
    'FileSystemObject
    Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    '許可する拡張子ﾘｽﾄ
    Dim ExtensionAry As Variant
    ExtensionAry = Array("CATProduct", "CATPart", "CATDrawing")
    
    '拡張子ﾁｪｯｸ
    If UBound(Filter(ExtensionAry, Fso.GetExtensionName(Path))) < 0 Then
        MsgBox Path & vbNewLine & "は、該当しない拡張子です"
        Exit Function
    End If
    
    'ﾌｧｲﾙ有無
    If Not Fso.FileExists(Path) Then
        MsgBox Path & vbNewLine & "が見つかりませんでした。"
        Exit Function
    End If
    
    'ﾌｧｲﾙ属性取得
    Dim Original As VbFileAttribute
    Original = Fso.GetFile(Path).Attributes
    
    '属性ﾁｪｯｸし読み込み
    If Original And vbReadOnly = vbReadOnly Then
        Call CATIA.Documents.Open(Path)
    Else
        Fso.GetFile(Path).Attributes = vbReadOnly
        Call CATIA.Documents.Open(Path)
        Fso.GetFile(Path).Attributes = Original
    End If
    CatOpen_ReadOnly = True
End Function

利用しやすいように、CatOpen_ReadOnly関数一本のみとしてます。

FileSelectionBoxを利用せずに、直接ﾌｧｲﾙﾊﾟｽ指定する場合は

Sub CATMain()
    'ﾌｧｲﾙを開く
    If CatOpen_ReadOnly("C:\temp\CubeInCube.CATPart") Then
        MsgBox "開けました"
    Else
        MsgBox "開けませんでした"
    End If
End Sub

こんな感じで大丈夫です。
(厳密な成功失敗の判断は、ｳｨﾝﾄﾞｳ数をﾁｪｯｸした方が正しいかも)

実は、ﾌｧｲﾙ属性に読み込み専用が含まれているかどうかを判断する関数を
こんな感じで作ってみたのですが

Private Function IsReadOnly(ByVal AttrType As VbFileAttribute) As Boolean
    IsReadOnly = AttrType And vbReadOnly = vbReadOnly
End Function

一行に二つの "＝" が・・・。　左は代入のｲｺｰﾙで、右が比較のｲｺｰﾙです。
VBAの悪魔仕様が出てきて気持ち悪かったので、却下しました。

2017-06-01

読み取り専用でﾌｧｲﾙを開く1

CATIA_V5 VBA

"読み取り専用でﾌｧｲﾙを開きたい" と御質問を頂きました。
過去に探した事が有り、"Unofficial CATIA User Forum" にも
記載したのですが･･･　生憎、ｿｰｽｺｰﾄﾞの管理が悪く　ｻﾝﾌﾟﾙが見つかりませんでした。

結論としては、CATIAのﾏｸﾛでﾄﾞｳｺｳでは無く、FileSystemObjectで
読み込むﾌｧｲﾙの属性を読み込み専用に変更した上で読み込み、
その後元に戻します。　要は読み込む瞬間だけ "読み込み専用"
としてしまえば良いだけでした。

ｻﾝﾌﾟﾙｺｰﾄﾞです。

'vba sample_FileOpen_ReadOnly_ver0.0.1
'読み取り専用でCATIAなﾌｧｲﾙを読み込む

Option Explicit
Private Const SelectionType = "*.CAT*" '"*.CATPart"
Private Const ReadOnly = 1& 'ﾌｧｲﾙ属性-読み取り専用

Sub CATMain()
    'ﾌｧｲﾙ選択
    Dim OpenFilePath As String
    Dim Msg As String: Msg = "読み取り専用で開くﾌｧｲﾙを選択してください"
    OpenFilePath = CATIA.FileSelectionBox(Msg, SelectionType, CatFileSelectionModeOpen)
    If OpenFilePath = vbNullString Then Exit Sub
    
    'ﾌｧｲﾙ属性取得
    Dim Original As Long: Original = GetAttributes(OpenFilePath)
    
    '属性ﾁｪｯｸし必要なら変更
    If Not (Original And ReadOnly = ReadOnly) Then
        Call SetAttributes(OpenFilePath, ReadOnly)
    End If
    
    '読み込み
    Call CATIA.Documents.Open(OpenFilePath)
    
    '属性を変更していたら元に戻す
    If Not (Original And ReadOnly = ReadOnly) Then
        Call SetAttributes(OpenFilePath, Original)
    End If
End Sub

'FileSystemObject
Private Function GetFSO() As Object
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'ﾌｧｲﾙ属性設定
Private Sub SetAttributes(ByVal Path As String, ByVal Value As Long)
    Dim Fso As Object: Set Fso = GetFSO
    Fso.GetFile(Path).Attributes = Value
End Sub

'ﾌｧｲﾙ属性取得
Private Function GetAttributes(ByVal Path As String) As Long
    Dim Fso As Object: Set Fso = GetFSO
    GetAttributes = Fso.GetFile(Path).Attributes
End Function

FileSelectionBoxを利用してﾌｧｲﾙを選択させていますが、単に開きたい
ﾌｧｲﾙのﾊﾟｽを指定してもOKです。

FileSelectionBoxについては、第二引数の表示させるﾌｧｲﾙの拡張子の
指定なのですが複数の拡張子を指定できなさそうな為、苦し紛れな
ﾜｲﾙﾄﾞｶｰﾄﾞを利用しています。
(catvbaやCATScript等、本来表示させるべきではないものまで表示されます)

実際にﾏｸﾛを利用して開いた感じはこちらです。
f:id:kandennti:20170601191835p:plain
CATIA上では "読み込み専用" となっていますが、実際のﾌｧｲﾙのﾌﾟﾛﾊﾟﾃｨ(右下)は
"読み込み専用" となっていません。

ﾌｧｲﾙは例の宿題です。　忙しい上に、機械が空かなかったり･･･(言い訳)

※涙が出るほどの初歩的な誤記を修正しました･･･。

2017-05-23

ｸﾘｯｸした面に法線を作成する

CATIA_V5 VBA KCL

こちらでｺﾒﾝﾄ頂いたのですが、時間がﾅｶﾅｶ確保できずに
ｻﾝﾌﾟﾙを作れませんでした。

3Dの文字モデリングマクロ8 - C#ATIA

正直な所、完成した状態がｲﾒｰｼﾞし切れていないため、ｸﾘｯｸした
面のｸﾘｯｸした位置に法線を作成するﾏｸﾛを作成してみました。

'vba sample_CreateLineNormal_ver0.01  using-'ver0.0.10'
'ｸﾘｯｸした面に法線を作成

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub

    'ﾕｰｻﾞｰ選択
    Dim Elm As Variant 'SelectedElement
    Set Elm = KCL.SelectElement("面を選択", "Face")
    If KCL.IsNothing(Elm) Then Exit Sub
    
    'ｸﾘｯｸ座標取得
    Dim Pos(2) As Variant 'Double
    Call Elm.GetCoordinates(Pos)
    
    '各必要なもの取得
    Dim Pt As Part
    Set Pt = Elm.Document.Part
    
    Dim Fact As HybridShapeFactory
    Set Fact = Pt.HybridShapeFactory
    
    Dim DelList As Collection
    Set DelList = New Collection
    
    '選択面Ref
    Dim SurfRef As Reference
    Set SurfRef = Elm.Reference
    
    'ｸﾘｯｸ位置の点
    Dim PntRef As Reference
    Set PntRef = CreatePntRef(Pt, Fact, Pos)
    Call DelList.Add(PntRef)
    
    '法線
    Dim LinRef As Reference
    Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 10#)
    Call DelList.Add(LinRef)
    
    'ﾃﾞｰﾀﾑ化
    Dim Dtm As HybridShapeLineExplicit
    Set Dtm = ToDatum(Pt, Fact, LinRef)
    
    '形状ｾｯﾄ作成
    Dim HBdy As HybridBody
    Set HBdy = Pt.HybridBodies.Add()
    Call HBdy.AppendHybridShape(Dtm)
    
    'お掃除
    Dim Ref As Reference
    For Each Ref In DelList
        Call Fact.DeleteObjectForDatum(Ref)
    Next
    
    MsgBox "Done"
End Sub

'ﾃﾞｰﾀﾑ化
Private Function ToDatum( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Ref As Reference) As HybridShapeLineExplicit
    Dim Dtm As HybridShapeLineExplicit
    Set Dtm = Fact.AddNewLineDatum(Ref)
    Call Pt.UpdateObject(Dtm)
    
    Set ToDatum = Dtm
End Function

'点
Private Function CreatePntRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Ary As Variant) As Reference
    Dim Pnt As HybridShapePointCoord
    Set Pnt = Fact.AddNewPointCoord(Ary(0), Ary(1), Ary(2))
    Call Pt.UpdateObject(Pnt)
    
    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromObject(Pnt)
    
    Set CreatePntRef = Ref
End Function

'法線
Private Function CreateNormalRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal SurfRef As Reference, _
                    ByVal PntRef As Reference, _
                    ByVal Lng As Double) As Reference
    Dim Lin As HybridShapeLineNormal
    Set Lin = Fact.AddNewLineNormal(SurfRef, PntRef, 0#, Lng, False)
    Call Pt.UpdateObject(Lin)
    
    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromObject(Lin)
    
    Set CreateNormalRef = Ref
End Function