こちらの続きです。
形状セット内の線の長さをExcelシートに出力する - C#ATIA
線を選択し続けながら、合計の長さを表示し、最後にExcelに
出力します。
'vba GetCurvesLength_ToExcel2 Sub CATMain() Dim TotalLen#: TotalLen = 0# '合計の長さ 'Partの取得 Dim Doc As PartDocument: Set Doc = CATIA.ActiveDocument Dim Pt As Part: Set Pt = Doc.Part 'HybridShapeFactory取得 - 形状判定の為必要 Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory '選択 Dim MsgBase$: MsgBase = "線を選択して下さい(選択終了:ESC)" Dim Msg$, Ref As Reference Dim CurveRefs As New Collection Do Msg = IIf(TotalLen = 0, MsgBase, MsgBase + " : 合計" + CStr(TotalLen) + "mm") Dim SelItem As SelectedElement: Set SelItem = SelectItem(Msg, Array("HybridShape")) If IsNothing(SelItem) Then Exit Do Set Ref = Pt.CreateReferenceFromObject(SelItem.Value) If IsCurve(Ref, Fact) Then Call CurveRefs.Add(Ref) TotalLen = TotalLen + GetLength(Ref, Pt) Else MsgBox "線(直線・円弧・スプライン)ではありません" End If Loop 'Excelのシートを取得 Dim Sheet As Object: Set Sheet = GetExcelSheet If IsNothing(Sheet) Then Exit Sub '測定しつつExcelに書き込み Dim CurveLeng# Dim I& For I = 1 To CurveRefs.Count CurveLeng = GetLength(CurveRefs(I), Pt) Sheet.Cells(I, 1) = CurveRefs(I).DisplayName Sheet.Cells(I, 2) = CurveLeng Next Sheet.Cells(CurveRefs.Count + 1, 1) = "合計" Sheet.Cells(CurveRefs.Count + 1, 2) = "=SUM(B1:B" + CStr(CurveRefs.Count) + ")" '終了 MsgBox "End" DoEvents AppActivate "Microsoft Excel" End Sub '長さの取得 Private Function GetLength#(ByVal Ref As Reference, ByVal Pt As Part) GetLength = Pt.Parent.GetWorkbench("SPAWorkbench").GetMeasurable(Ref).Length End Function '線の判断 Private Function IsCurve(ByVal Ref As Reference, ByVal Fact As HybridShapeFactory) As Boolean Dim GeoType&: GeoType = Fact.GetGeometricalFeatureType(Ref) 'AutomationManualの記述が間違えやすいが、 '2-Curve , 3-Line , 4-Circle になる IsCurve = IIf(GeoType >= 2 And GeoType <= 4, True, False) End Function '起動中のExcelのアクティブブックのアクティブシートを取得 Private Function GetExcelSheet() As Object On Error Resume Next Dim Xls As Object Set Xls = GetObject(, "Excel.Application") Set GetExcelSheet = Xls.ActiveSheet On Error GoTo 0 Err.Clear End Function '選択 ''' @param:Msg-メッセージ ''' @param:Filter-選択フィルター(指定無し時AnyObject) ''' @return:AnyObject Public Function SelectItem(ByVal Msg$, _ Optional ByVal Filter As Variant = Empty) _ As SelectedElement If IsEmpty(Filter) Then Filter = Array("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) Sel.Clear End Function 'Nothing 書き方に統一感が無い為 ''' @param:OJ-Variant(Of Object) ''' @return:Boolean Public Function IsNothing(ByVal Oj As Variant) As Boolean IsNothing = Oj Is Nothing End Function
マクロ実行時にはExcelのBookを開いた状態にしておく必要があります。
実行した際の最初は、ステータスバーの表示は
"線を選択して下さい(選択終了:ESC)"
となっていますが、
1本選択後はステータスバーの最後の部分に、選択済みの線の合計長さが、
表示されます。
イチイチMsgBoxを表示させるより、ストレス無く操作できるかと思います。
ESCキーで選択を終了し、Excel側に結果をエクスポート。
画像のB6セルには "=SUM(B1:B5)" が入力され、選択された線の
合計を出しています。
正直に書くと、このマクロは同一の曲線を選択した際も、次々と
合計してしまうので、本来であれば重複選択を削除するための
処理が必要かと思われます。
直感的にはInternalNameを利用するのが良いのかな?と思います。
InternalNameテスト - C#ATIA
・・・お望みの形とちょっと違うかも知れません。
追記です。
スイマセン、前回のリンク先が違っていました。
又、コードと説明の画像が食い違う部分がありましたので、
修正しました。
前回のコードを流用し、Excel側だけですが合計を出すようにするには
①②の部分を書き足せば大丈夫だと思います。
・・・ '測定しつつExcelに書き込み Dim CurveLeng# Dim I& For I = 1 To CurveRefs.Count CurveLeng = Pt.Parent.GetWorkbench("SPAWorkbench") _ .GetMeasurable(CurveRefs(I)).Length Sheet.Cells(I, 1) = CurveRefs(I).DisplayName Sheet.Cells(I, 2) = CurveLeng Next Sheet.Cells(CurveRefs.Count + 1, 1) = "合計" '① Sheet.Cells(CurveRefs.Count + 1, 2) = "=SUM(B1:B" + CStr(CurveRefs.Count) + ")" '② ・・・