CATIA V5です。
先日、絶対座標での寸法値位置の取得が出来ました。
Drawの寸法値に四角を描く - C#ATIA
これを元に連番となる番号バルーンを作ります。
・・・バルーンはDrawingTextオブジェクトなのですが、
DrawingTextsオブジェクトにはバルーンを作る為のメソッドが
無さそうです。
r1 DrawingTexts (Collection)
となると、最後の手段はコピペです。
目的のビューにバルーンさえあれば、バルーンはX/Yプロパティで
r1 DrawingText (Object)
引き出し線はModifyPointメソッドで移動可能だと分かりました。
r1 DrawingLeader (Object)
(後に海外サイトで検索したところ、バルーンはやはりコピペで行うようです)
取りあえず、通常のシートでも構わないのですが、意図したものでは無い
と言う意味を込めてテンプレートとして使うバルーンを、ディテールシートに
ビューを作り入れておきます。
続いて、目的のシートをアクティブにしこちらのマクロを実行します。
'vba using-'KCL0.1.0' by Kantoku 'アクティブなシートの全寸法に番号バルーンを付ける 'バルーンレポートビュー名 Private Const BALLOON_VIEW_NAME = "BALLOON" 'テンプレートバルーン名 Private Const TEMPLATE_SHEET_NAME = "template" Private Const TEMPLATE_BALLOON_NAME = "balloon" 'true/false vbaとCATIA API食い違い代案 Private Enum BOOL boolFalse = 0 boolTrue = 1 End Enum Option Explicit Sub CATMain() Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim sheet As DrawingSheet Set sheet = dDoc.sheets.ActiveSheet KCL.SW_Start Dim balloonInfo As Variant balloonInfo = get_template_balloon() If UBound(balloonInfo) < 2 Then Exit Sub End If 'test Dim baseView As DrawingView Set baseView = sheet.views.item(3) Dim baseBalloon As DrawingText Set baseBalloon = copy_and_paste(balloonInfo, baseView) Dim templateIndex As Long templateIndex = baseView.texts.count Dim baseInfo As Variant baseInfo = Array( _ sheet, _ baseView, _ baseBalloon _ ) Dim drawDims As Variant Dim balloonView As DrawingView Set balloonView = get_view_by_name( _ BALLOON_VIEW_NAME) Dim view As DrawingView Dim i As Long Dim balloon As DrawingText Dim center As Variant Dim sel As Selection Set sel = dDoc.Selection sel.Clear sel.Add baseBalloon sel.Copy sel.Clear CATIA.HSOSynchronized = False Dim balloonIdx As Long balloonIdx = 1 For Each view In sheet.views drawDims = get_dimensions_by_view(view) If UBound(drawDims) < 1 Then GoTo continue End If For i = 0 To UBound(drawDims) center = get_center_of_boundary_box( _ get_boundary_box_by_dimension( _ drawDims(i) _ ) _ ) Set balloon = pre_copide_and_paste(balloonView) move_balloon _ balloon, _ Array( _ center(0) + 10#, _ center(1) + 10# _ ), _ center balloon.text = CStr(balloonIdx) balloonIdx = balloonIdx + 1 Next CATIA.RefreshDisplay = True continue: Next baseView.texts.Remove templateIndex CATIA.HSOSynchronized = True MsgBox "Done : " & KCL.SW_GetTime End Sub '寸法文字の範囲取得 Private Function get_boundary_box_by_dimension( _ ByVal drawDim As DrawingDimension) _ As Variant Dim view As DrawingView Set view = KCL.GetParent_Of_T(drawDim, "DrawingView") Dim viewX As Double viewX = view.xAxisData Dim viewY As Double viewY = view.yAxisData Dim viewScale As Double viewScale = view.Scale Dim valDim As Variant Set valDim = drawDim Dim bBox(7) As Variant valDim.GetBoundaryBox bBox Dim bBoxCount As Long bBoxCount = UBound(bBox) \ 2 Dim i As Long For i = 0 To bBoxCount bBox(i * 2) = bBox(i * 2) * viewScale + viewX bBox(i * 2 + 1) = bBox(i * 2 + 1) * viewScale + viewY Next get_boundary_box_by_dimension = bBox End Function '検索し配列で取得 Private Function get_search_items( _ ByVal searchWord As String, _ Optional selectEntity = Nothing) _ As Variant Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim sel As Selection Set sel = dDoc.Selection CATIA.HSOSynchronized = False sel.Clear If Not selectEntity Is Nothing Then sel.Add selectEntity End If sel.Search searchWord If sel.Count2 < 1 Then get_search_items = Array() Exit Function End If Dim drawDims() As Variant ReDim drawDims(sel.Count2 - 1) Dim i As Long For i = 1 To sel.Count2 Set drawDims(i - 1) = sel.item(i).value Next sel.Clear CATIA.HSOSynchronized = True get_search_items = drawDims End Function 'ビュー内の寸法取得 Private Function get_dimensions_by_view( _ ByVal view As DrawingView) _ As Variant get_dimensions_by_view = get_search_items( _ "CATDrwSearch.DrwDimension,sel", _ view _ ) End Function 'ビューを名前で取得 'Optional isCreate - true:なきゃ作る false:なきゃnothing Private Function get_view_by_name( _ ByVal name As String, _ Optional isCreate = True) _ As DrawingView Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim views As DrawingViews Set views = dDoc.sheets.ActiveSheet.views Dim view As DrawingView For Each view In views If Not view.name = name Then GoTo continue End If Set get_view_by_name = view Exit Function continue: Next If isCreate Then Set get_view_by_name = views.Add(name) Else Set get_view_by_name = Nothing End If End Function 'シートを名前で取得 Private Function get_sheet_by_name( _ ByVal name As String, _ Optional isDetail As Integer) _ As DrawingSheet Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim sheets As DrawingSheets Set sheets = dDoc.sheets Dim sheet As DrawingSheet For Each sheet In sheets If Not sheet.name = name Then GoTo continue End If If sheet.isDetail <> isDetail Then GoTo continue End If Set get_sheet_by_name = sheet Exit Function continue: Next Set get_sheet_by_name = Nothing End Function 'テンプレートバルーンの取得 'return array(DrawingSheet, DrawingView, drawingtext) Private Function get_template_balloon() _ As Variant get_template_balloon = Array() Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim backupSheet As DrawingSheet Set backupSheet = dDoc.sheets.ActiveSheet.views Dim sheet As DrawingSheet Set sheet = get_sheet_by_name(TEMPLATE_SHEET_NAME, BOOL.boolTrue) If sheet Is Nothing Then MsgBox "テンプレートディテールシートがありません" Exit Function End If sheet.Activate Dim view As DrawingView Set view = get_view_by_name(TEMPLATE_BALLOON_NAME) If view Is Nothing Then MsgBox "テンプレートビューがありません" backupSheet.Activate Exit Function End If view.Activate Dim items As Variant items = get_search_items( _ "CATDrwSearch.DrwBalloon,sel", _ view _ ) If UBound(items) < 0 Then MsgBox "テンプレートバルーンがありません" backupSheet.Activate Exit Function End If '最初にHitしたバルーン get_template_balloon = Array(sheet, view, items(0)) backupSheet.Activate End Function 'コピー済みの状態からペースト Private Function pre_copide_and_paste( _ ByVal targetView As DrawingView) _ As DrawingText Dim targetSheet As DrawingSheet Set targetSheet = KCL.GetParent_Of_T(targetView, "DrawingSheet") Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim sel As Selection Set sel = dDoc.Selection targetSheet.Activate 'targetView.Activate sel.Add targetView sel.Paste Set pre_copide_and_paste = sel.Item2(1).value sel.Clear End Function 'バルーン情報からターゲットにコピペ Private Function copy_and_paste( _ ByVal balloonInfo As Variant, _ ByVal targetView As DrawingView) _ As DrawingText Dim targetSheet As DrawingSheet Set targetSheet = KCL.GetParent_Of_T(targetView, "DrawingSheet") Dim sheet As DrawingSheet Set sheet = balloonInfo(0) Dim view As DrawingView Set view = balloonInfo(1) Dim balloon As DrawingText Set balloon = balloonInfo(2) Dim dDoc As DrawingDocument Set dDoc = CATIA.ActiveDocument Dim sel As Selection Set sel = dDoc.Selection sel.Clear sheet.Activate view.Activate sel.Add balloon sel.Copy sel.Clear Set copy_and_paste = pre_copide_and_paste( _ targetView _ ) sel.Clear End Function 'バルーンの移動 Private Sub move_balloon( _ ByVal balloon As DrawingText, _ textPos As Variant, _ leaderPos As Variant) Dim drawLeader As DrawingLeader Set drawLeader = balloon.leaders.item(1) balloon.x = textPos(0) balloon.y = textPos(1) drawLeader.ModifyPoint 1, leaderPos(0), leaderPos(1) End Sub 'バウンダリボックスの中心 Private Function get_center_of_boundary_box( _ bBox As Variant) _ As Variant get_center_of_boundary_box = Array( _ (bBox(0) + bBox(6)) * 0.5, _ (bBox(1) + bBox(3)) * 0.5 _ ) End Function
正直な所、無駄な所が有る事に気が付いている上、とにかく汚いので
直したい所なのですが、紛失しそうなのでUpしておきます・・・。
耐え切れず、自作ライブラリを使用しています。
試したい方は、こちらからダウンロードやコピペし、
同じプロジェクト内に"kcl"と言う名前の標準モジュールを
置いておいてください。
github.com
動作はこんな感じです。
通常のマクロに比べ、コピペはとにかく遅いです。
とは言え、243個の連番バルーンを20秒程で作ってくれるのは
楽ですね。出来上がりはひどいのですが、位置を調整するだけ
であれば、かなり負担も減りそうです。
今回試してみて分かったのが、コピペ(特にペースト)の方法です。
バルーンを寸法の数だけコピペする必要があったのですが、
最初は
コピー -> ペースト -> 位置・文字修正 -> コピー -> ペースト -> 位置・文字修正・・・
で処理させていましたが、兎に角遅かったです。
よく考えた所、コピー自体は1回で良かったんです。
つまり、
コピー -> ペースト -> 位置・文字修正 -> ペースト -> 位置・文字修正・・・
で大丈夫でした。
但し、クリップボードを利用しているので、マクロ実行中は他でコピーを
行うとNGだと思います。
あぁこれが出来るのであれば、5年ぐらい前に取り組めばよかった。
やっと半分ぐらい出来たかな?