C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

外部ﾌｧｲﾙから点を3Dに取り込む2

CATIA_V5 VBA

こちらの続きです。
外部ﾌｧｲﾙから点を3Dに取り込む1 - C#ATIA

これは過去に "Unofficial CATIA User Forum" でUpしたものです。
CATVBA や CATVBScript では無く、VBScriptです。
VBScriptで作成するメリットは、D&Dが利用出来るところでしょうか？

ｿｰｽｺｰﾄﾞです。

'VBScript
Language = "VBSCRIPT"
'Option Explicit
'*************************
'CAT_CSV_Inport
'CSVファイル形式の座標値を、点としてCATIAのファイルに取り込みます
'簡単な説明です。アイコンをダブルクリックしても表示されます。
Dim sDClickMsg
sDClickMsg = "CSVファイル形式の座標値を、CATIAのファイルに取り込みます。" & vbCrLf & vbCrLf & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "○取り込みファイルについて" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・CSV形式ではない場合は、Excelやメモ帳等を使用して各座標の区切りを「,」にして下さい。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・数値の状態は「X,Y」又は「X,Y,Z」の順に並んでいることを前提に取り込み、4個目以降に" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "　入っている数値は、無視します。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・データが「X,Y」のものを3Dに取り込む場合、Zの値は「0」として行います。" & vbCrLf & vbCrLf & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "○取り込み実行" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "1)CATIAを起動・ファイルを開き、取り込みを行うワークベンチにしておきます。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "2)本ファイルにCSVファイルをD&Dします。" & vbCrLf & vbCrLf & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "○対応ワークベンチ" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・パート・デザイン：絶対座標値として通常の取り込みを行います。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・ジェネレーティブ・シェープ・デザイン：パートと同様です。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・アセンブリー・デザイン：取り込み先のパートを指定してから実行されます。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "　※キャッシュ利用している場合、PartファイルであってもCGRファイルとなっている" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "　　可能性があるため指定できません。事前にロードを行ってください。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・プロダクト・ストラクチャー：アセンブリーと同様です。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・スケッチャー：X座標→H座標　Y座標→V座標　Z座標→無視として取り込みます。" & vbCrLf & vbCrLf
sDClickMsg = sDClickMsg & "・ドラフティング：アクティブなビューに対し、Z座標を無視して取り込みます。" & vbCrLf & vbCrLf
'*************************

Dim Catia 'catia
Dim FSO 'FileSystemObject
Dim TakashimaEGFG 'As Boolean
Dim oActDoc 'As Document
Dim oSel 'As Selection
Dim sMsg '各種メッセージ

Const PART = 1 'パート-PrtCfg
Const DRW = 3 'ドラフティング-Drw
Const ASSY = 4 'アセンブリ-Assembly
Const SKET = 5 'スケッチャ-CS0WKS

'*********
Call Main
Set FSO = Nothing
Set oActDoc = Nothing
Set oSel = Nothing
wscript.Quit 0
'*********

Private Sub Main()
    'メインルーチン
    Dim i 'As Integer
    Dim InputType(0) 'As Variant'Assy-SelectElement2用
    Dim Result 'ユーザー入力結果
    Dim WBtype 'As Integer'WBタイプ
    Dim objArgs 'D&D
    Dim sCsv 'csvファイル-配列
    Dim aryPos '座標値配列
    Dim oTempPart ' As PART 'ActivePart取得用-Assy対策
    Dim oSketch 'As Sketch 'ActiveSketch取得用
    Dim ConFG 'As Boolean '拘束オプション
    Dim sFilePath 'D&Dファイル名
    
    Do
        'D&Dチェック
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objArgs = wscript.Arguments 'debug
        If Drop(objArgs) Then Exit Do 'debug
        
        On Error Resume Next
            'Catia起動チェック
            Set Catia = GetObject(, "CATIA.Application") 'debug
            If Err.number <> 0 Then Exit Do
            'Catiaファイルオープンチェック
            If Catia.Windows.Count < 1 Then
                sMsg = "インポートするファイルを開いてください"
                Exit Do
            End If
        On Error GoTo 0
        
        'WBチェック
        WBtype = WBcheck(Catia.GetWorkbenchId)
        If WBtype = 0 Then
            sMsg = "未対応のワークベンチです"
            MsgBox (sMsg)
            Exit Do
        End If
        
        'ファイルパス等取得
        sFilePath = objArgs(0)
        Set objArgs = Nothing
        
        'ファイル読み込み
        sCsv = InPortFile(sFilePath, 0)
      
        'CSV座標変換
        aryPos = CreatePos(sCsv)
        If UBound(aryPos, 2) = 0 Then
            sMsg = "取り込むべきデータがありません" & vbCrLf
            sMsg = sMsg & "D&Dファイルをチェックしてみてください"
            Exit Do
        End If
        
        'WB別　点作成
        Set oActDoc = Catia.ActiveDocument
        Set oSel = oActDoc.Selection
        Select Case WBtype
            Case PART
                With oSel
                    Call .Clear
                    Call .Search("((((((CATProductSearch.Part + CATStFreeStyleSearch.PartFeature) + CATAsmSearch.Part) + CATPrtSearch.PartFeature) + CATGmoSearch.PartFeature) + CATSpdSearch.PartFeature) + CATPcsSearch.Part),in")
                    Set oTempPart = .Item(1).Value
                    Call .Clear
                End With
                Call Del_OJ(oSel, CreateGSD_Point(oTempPart, aryPos))
                sMsg = "処理が終了しました"
                
                Set oTempPart = Nothing
            Case ASSY
                InputType(0) = "Part"
                With oSel
                    Call .Clear
                    sMsg = "インポート先Partを指定してください // [Esc]=Cancel"
                    Result = .SelectElement2(InputType, sMsg, False)
                    If Result <> "Cancel" Then
                        Call Del_OJ(oSel, CreateGSD_Point(.Item(1).Value, aryPos))
                        sMsg = "処理が終了しました"
                    Else
                        sMsg = ""
                    End If
                End With
            Case SKET
                sMsg = "インポートの際、拘束を省略しますか？"
                ConFG = MsgBox(sMsg, vbYesNo) - 6
                With oSel
                    Call .Clear
                    Call .Search("CATPrtSearch.Sketch,in")
                    Set oSketch = .Item(1).Value
                    Call .Clear
                End With
                Call Create2DPoint(SKET, oSketch, ConFG, aryPos)
                sMsg = "処理が終了しました"
                
                Set oSketch = Nothing
                Set ConFG = Nothing
            Case DRW
                Call Create2DPoint(DRW, oActDoc.Sheets.ActiveSheet.Views.ActiveView, False, aryPos)
                sMsg = "処理が終了しました"
        End Select
        Exit Do
    Loop
    
    '終了前処理
    Select Case Err.number
        Case 0
            '正常終了
        Case 429 'CATIA起動していないエラー
            sMsg = "CATIAが起動されていません"
        Case Else
            sMsg = "エラーにより中止します"
    End Select

    If Len(sMsg) <> 0 Then
        Call MsgBox(sMsg)
    End If
    On Error Resume Next
        Erase aryPos
    On Error GoTo 0
End Sub

Private Function Drop(DDFiles)
    'ドロップ処理
    If DDFiles.Count = 0 Then
        'ダブルクリック
        Call MsgBox(sDClickMsg, vbOKOnly, "説明")
        Drop = True
    ElseIf DDFiles.Count > 1 Then
        'ファイルが複数
        sMsg = "D&DするCSV形式のファイルは、1つにしてください"
        MsgBox (sMsg)
        Drop = True
    Else
        Drop = False
    End If
End Function

Private Function WBcheck(ByVal sWorkbench) 'As String)
    '現在のワークベンチ取得し、処理方法を判断
    Select Case sWorkbench
        Case "PrtCfg", "CATShapeDesignWorkbench"
            WBcheck = PART
        Case "Drw"
            WBcheck = DRW
        Case "Assembly", "PrsConfiguration"
            WBcheck = ASSY
        Case "CS0WKS"
            WBcheck = SKET
        Case Else
            WBcheck = 0
    End Select
End Function

Private Function InPortFile(ByVal sPath, ByVal iDammy)
    'ファイル読み込み
    Dim sTxt, Buf, TS, lngRowMax
    
    With FSO.GetFile(sPath).OpenAsTextStream
            Buf = .ReadAll
        .Close
    End With
    Set TS = FSO.OpenTextFile(sPath)
    lngRowMax = TS.Line
    Set TS = Nothing
    ReDim sTxt(lngRowMax + iDammy)
    sTxt = Split(Buf, CheckCRLF(Buf), -1, 1)
    InPortFile = sTxt
    
    Erase sTxt
End Function

Private Function CreateGSD_Point(ByVal oPart, ByVal Pts)
'(ByVal oPart As PART, ByVal Pts)
    '3DのPOINT作成
    Dim oHBFactory 'As HybridShapeFactory
    Dim oAxis 'As AxisSystem
    Dim oHybridBody 'As HybridBody
    Dim oHybShpPt 'As HybridShapePointCoord
    Dim oHybShpPtExp 'As HybridShapePointExplicit
    Dim oPt, i
    
    Set oHBFactory = oPart.HybridShapeFactory
    Set oAxis = CreateAxis(oPart)
    Set oHybridBody = oPart.HybridBodies.Add()
    oHybridBody.Name = "Inport_CSV"

    'ダミー作成
    oPt = Array(0, 0, 0)
    Set oHybShpPt = oHBFactory.AddNewPointCoord(oPt(0), oPt(1), oPt(2))
    Call oPart.UpdateObject(oHybShpPt)
    
    '点作成
    For i = 0 To UBound(Pts, 2)
        oPt = Array(CDbl(Pts(0, i)), CDbl(Pts(1, i)), CDbl(Pts(2, i)))
        Call oHybShpPt.SetCoordinates(oPt)
        Call oPart.UpdateObject(oHybShpPt)
        Set oHybShpPtExp = oHBFactory.AddNewPointDatum(oHybShpPt)
        Call oHybridBody.AppendHybridShape(oHybShpPtExp)
        Call oPart.UpdateObject(oHybShpPtExp)
    Next
    
    With oHBFactory
        .DeleteObjectForDatum oHybShpPt
    End With
    Set CreateGSD_Point = oAxis
    
    Set oHBFactory = Nothing
    Set oAxis = Nothing
    Set oHybridBody = Nothing
    Set oHybShpPt = Nothing
    Set oHybShpPtExp = Nothing
End Function

Private Function CreateAxis(ByVal oPart) ' As PART)
    '座標系作成
    Dim colAxiss 'As AxisSystems
    Dim oAxis 'As AxisSystem
    Dim oAxisSysVnt ' As Variant
    
    Set colAxiss = oPart.AxisSystems
    Set oAxis = colAxiss.Add()
    With oAxis
        .Type = catAxisSystemStandard
        .OriginType = catAxisSystemOriginByCoordinates
        .XAxisType = catAxisSystemAxisByCoordinates
        .YAxisType = catAxisSystemAxisByCoordinates
        .ZAxisType = catAxisSystemAxisByCoordinates
        .IsCurrent = False
    End With
    Set oAxisSysVnt = oAxis
    With oAxisSysVnt
        .PutOrigin Array(CDbl(0), CDbl(0), CDbl(0))
        .PutXAxis Array(CDbl(1), CDbl(0), CDbl(0))
        .PutYAxis Array(CDbl(0), CDbl(1), CDbl(0))
        .PutZAxis Array(CDbl(0), CDbl(0), CDbl(1))
    End With
    oPart.UpdateObject oAxis
    Set CreateAxis = oAxis
    
    Set colAxiss = Nothing
    Set oAxis = Nothing
End Function

Private Sub Del_OJ(ByVal oSel, ByVal OJ)
    'セレクションによるオブジェクト削除
    With oSel
        Call .Clear
        Call .Add(OJ)
        Call .Cut
        Call .Clear
    End With
End Sub

Private Sub Create2DPoint(ByVal iWB, ByRef oWorkSpace, ByVal ConstFG, ByVal Pts)
    '2DのPOINT作成
    'oWorkSpace SKET-Sketch,DRW-DrawingView
    Dim oFac2D 'As Factory2D
    Dim oAxis2D 'As Axis2D
    Dim oRefH 'As Reference
    Dim oRefV 'As Reference
    Dim oRefPnt 'As Reference
    Dim oPart 'As PART
    Dim i 'As Integer
    Dim oPnt2D 'As point2D
    Dim oConstH 'As Constraint
    Dim oConstV 'As Constraint
    Dim colConst 'As Constraints
    
    Set oFac2D = oWorkSpace.Factory2D
    If iWB = SKET Then
        With oWorkSpace
            Set colConst = .Constraints
            Set oAxis2D = .GeometricElements.Item(1) '日本"絶対座標軸":英語"AbsoluteAxis"
        End With
        With oSel
            Call .Clear
            Call .Add(oWorkSpace)
            Set oPart = .FindObject("CATIAPart")
            Call .Clear
        End With
        With oAxis2D
            Set oRefH = oPart.CreateReferenceFromObject(.HorizontalReference)
            Set oRefV = oPart.CreateReferenceFromObject(.VerticalReference)
        End With
    End If
    For i = 0 To UBound(Pts, 2)
        Set oPnt2D = oFac2D.CreatePoint(CDbl(Pts(0, i)), CDbl(Pts(1, i)))
        oPnt2D.Construction = False
        If ConstFG Then
            Set oRefPnt = oPart.CreateReferenceFromObject(oPnt2D)
            With colConst
                Set oConstH = colConst.AddBiEltCst(1, oRefH, oRefPnt) 'VBS:第一引数catCstTypeDistanceではNG
                Set oConstV = colConst.AddBiEltCst(1, oRefV, oRefPnt) 'VBS:第一引数catCstTypeDistanceではNG
                Set oConstH = Nothing
                Set oConstV = Nothing
            End With
            Set oPnt2D = Nothing
        End If
    Next
    
    Set oFac2D = Nothing
    Set oAxis2D = Nothing
    Set oRefH = Nothing
    Set oRefV = Nothing
    Set oRefPnt = Nothing
    Set oPart = Nothing
    Set oPnt2D = Nothing
    Set oConstH = Nothing
    Set oConstV = Nothing
    Set colConst = Nothing
End Sub

Private Function CreatePos(ByVal sCsv)
    'CSVを座標変換-数値的に細かくても無駄のため小数点以下3桁まで
    Dim Pos(2) 'As Double '座標値 0-x,1-y,2-z
    Dim aryPos() '座標値配列
    Dim tempPos 'As Text '一時座標値
    Dim xyzcount 'As Integer
    Dim iTenPos 'As Integer
    
    ReDim aryPos(2, UBound(sCsv) - 1)
    For i = 0 To UBound(sCsv) - 1
        tempPos = sCsv(i)
        xyzcount = 0
        Do
            Pos(xyzcount) = CDbl(GetValue(tempPos))
            iTenPos = InStr(1, tempPos, ",")
            If iTenPos = 0 Then
                Exit Do
            End If
            tempPos = Mid(tempPos, iTenPos + 1)
            xyzcount = xyzcount + 1
        Loop Until xyzcount > 2
        If xyzcount > 0 Then
            aryPos(0, i) = CDbl(Pos(0)): Pos(0) = 0
            aryPos(1, i) = CDbl(Pos(1)): Pos(1) = 0
            If xyzcount > 1 Then
                aryPos(2, i) = CDbl(Pos(2)): Pos(2) = 0
            End If
        End If
    Next
    CreatePos = aryPos
    
    Erase Pos
    Erase aryPos
End Function

Function CheckCRLF(ByVal sWord)
    '簡易改行チェック
    Dim CrFg, LfFg
    
    CrFg = InStr(sWord, vbCr)
    LfFg = InStr(sWord, vbLf)
    
    If CrFg <> 0 Then
        If LfFg <> 0 Then
            CheckCRLF = vbCrLf
        Else
            CheckCRLF = vbCr
        End If
    ElseIf LfFg <> 0 Then
        CheckCRLF = vbLf
    Else
        '改行が無い
        CheckCRLF = vbCrLf
    End If
End Function

Private Function GetValue(sTxt)
    'Valの代わり
    Dim i, temp
    
    For i = 1 To Len(sTxt)
        If blnCheck(Mid(sTxt, i, 1)) = False Then
            Exit For
        End If
    Next
    If i = 1 Then
        GetValue = 0
    Else
        GetValue = Left(sTxt, i - 1)
    End If
End Function

Function blnCheck(strLen)
    '正規表記による数字のチェック
    Dim objRE
    Set objRE = New RegExp
    objRE.IgnoreCase = True
    objRE.Pattern = "[0-9.+-]"
    blnCheck = objRE.test(strLen)
    Set objRE = Nothing
End Function

簡単な説明は、ｿｰｽｺｰﾄﾞ先頭付近に記載しています。
又、面倒な方はｻﾝﾌﾟﾙと共に下記のｻｲﾄにUpしていますので
DLして下さい。
https://grabcad.com/library/csvfile-inport-test-1
今見るとｲﾏｲﾁな部分が多々見られます・・・。

VBScriptだとｱｳﾄﾌﾟﾛｾｽになる為、遅いです。
(3000点のｻﾝﾌﾟﾙをｽｹｯﾁの拘束付きで行うと、物凄く時間かかります)
こちらに記載した "システムメニューを表示させる" を行うと、
マクロを高速に実行させる(非公式) - C#ATIA
表示させない時との違いを体感できるかと思います。