CATIA V5です。
業務で測定用の図面を作成するのですが、寸法にバルーンでナンバリング
してます。 ・・・面倒です。
自動化出来れば良いのですが、拘る部分もあり、なかなか良い方法を
思い付かないのでチマチマやってます。
極まれに、修正で番号を追加となった際に "一体幾つが最後の番号なのか？"
を見失わない為に、図面枠外にメモってます。
驚くほどに原始的・・・。ミスする可能性もあります。
重い腰を上げて、数字のバルーン文字の最小最大を確認する為のマクロを
作りました。
Option Explicit
Sub CATMain()
Dim balloonNumbers As Variant
balloonNumbers = quick_sort( _
get_balloon_text_numeric_array( _
get_balloon_list() _
) _
)
Dim msg As String
If IsEmpty(balloonNumbers) Then
msg = "数字のバルーンが見つかりませんでした"
Else
msg = "先頭の番号:" & balloonNumbers(0) & vbCrLf & _
"最後の番号:" & balloonNumbers(UBound(balloonNumbers))
End If
MsgBox msg
End Sub
Private Function get_balloon_text_numeric_array( _
ByVal balloonList As Collection) _
As Variant
Dim numbers As Collection
Set numbers = New Collection
Dim balloon As DrawingText
Dim txt As String
For Each balloon In balloonList
txt = balloon.Text
If Not IsNumeric(txt) Then GoTo continue
numbers.Add (Val(txt))
continue:
Next
get_balloon_text_numeric_array = collection_to_array(numbers)
End Function
Private Function collection_to_array( _
lst As Collection) _
As Variant
If lst.count < 1 Then
collection_to_array = Empty
Exit Function
End If
Dim ary() As Variant
ReDim ary(lst.count - 1)
Dim i As Long
For i = 1 To lst.count
ary(i - 1) = lst(i)
Next
collection_to_array = ary
End Function
Private Function get_balloon_list() _
As Collection
Dim dDoc As DrawingDocument
Set dDoc = CATIA.ActiveDocument
Dim sel As Selection
Set sel = dDoc.Selection
CATIA.HSOSynchronized = False
sel.Search "CATDrwSearch.DrwBalloon,all"
Dim balloons As Collection
Set balloons = New Collection
Dim i As Long
For i = 1 To sel.Count2
balloons.Add sel.Item(i).value
Next
sel.Clear
CATIA.HSOSynchronized = True
Set get_balloon_list = balloons
End Function
Private Function quick_sort( _
ByVal ary As Variant) As Variant
If IsEmpty(ary) Then
quick_sort = Empty
Exit Function
End If
Dim stack As Object
Set stack = CreateObject("Scripting.Dictionary")
Dim leftIdx As Long
Dim rightIdx As Long
Dim pivot As Variant
Dim tPivot(2) As Variant
Dim temp As Variant
Dim i As Long
Dim j As Long
stack.Add stack.count + 1, LBound(ary)
stack.Add stack.count + 1, UBound(ary)
Do While stack.count > 0
leftIdx = stack(stack.count - 1)
rightIdx = stack(stack.count)
stack.Remove stack.count
stack.Remove stack.count
If leftIdx < rightIdx Then
pivot = ary((leftIdx + rightIdx) / 2)
i = leftIdx
j = rightIdx
Do While i <= j
Do While ary(i) < pivot
i = i + 1
Loop
Do While ary(j) > pivot
j = j - 1
Loop
If i <= j Then
temp = ary(i)
ary(i) = ary(j)
ary(j) = temp
i = i + 1
j = j - 1
End If
Loop
If rightIdx - i >= 0 Then
If rightIdx - i <= 10 Then
insertion_sort ary, i, rightIdx
Else
stack.Add stack.count + 1, i
stack.Add stack.count + 1, rightIdx
End If
End If
If j - leftIdx >= 0 Then
If j * leftIdx <= 10 Then
insertion_sort ary, leftIdx, j
Else
stack.Add stack.count + 1, leftIdx
stack.Add stack.count + 1, j
End If
End If
End If
Loop
quick_sort = ary
End Function
Private Function insertion_sort( _
ary As Variant, _
minIdx As Long, _
maxIdx As Long)
Dim i As Long, j As Long
Dim temp As Variant
j = 1
For j = minIdx To maxIdx
i = j - 1
Do While i >= 0
If ary(i + 1) < ary(i) Then
temp = ary(i + 1)
ary(i + 1) = ary(i)
ary(i) = temp
Else
Exit Do
End If
i = i - 1
Loop
Next
insertion_sort = ary
End Function
ソート処理が必要なのですが、Excelであればあるようなのですが
VBAは無いんですね・・・。
こちらのクイック・挿入ハイブリッドソートをお借りしました。
クイックソートと挿入ソートのハイブリッド | 愚者の経験
破壊的部分や大文字な部分は好みの関係で修正しています。
クイック・挿入ハイブリッドソートが一番高速だと言う事は、
僕も知っています。
実際にこの様な図面で
マクロを使用するとこんな感じです。
本当は番号の重複や欠番等のチェックも入れたいのですが、
ご覧の通り、まだまだバルーン作らなきゃいけないんです。
（しかも3枚組の1枚目）
〇追記
実際使ったら全バルーンが検索されていたので、
アクティブシート内だけにする為、get_balloon_list関数内を
変更しました。
sel.Add dDoc.sheets.ActiveSheet
sel.Search "CATDrwSearch.DrwBalloon,sel"
