PartNumberをファイル名に書き換える

久々のCATIAなのですが、ちょっと残念な奴です。

Productの際、ぶら下がったPartNumberをファイル名に書き換える
と言う、今さら感の強いやつです。

'vba Assy_ProductReNamem_ver0.0.1  using-'KCL0.1.0'  by Kantoku

Option Explicit

Private mFSO As Object

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not KCL.CanExecute("ProductDocument") Then Exit Sub
    
    Set mFSO = KCL.GetFSO()
    Dim msg As String
    
    'ﾄｯﾌﾟ取得
    Dim root As Products
    Set root = CATIA.ActiveDocument.Product.Products
    
    Dim docs As Collection
    Set docs = New Collection
    Set docs = GetRenameDoc(GetAllDoc(root, docs))
    
    If docs.count < 1 Then
        msg = "修正すべきﾄﾞｷｭﾒﾝﾄがありませんでした"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    '確認
    msg = GetRenameListMsg(docs)
    If MsgBox(msg, vbYesNo + vbQuestion) = vbNo Then
        Exit Sub
    End If
    
    'rename
    Call ExecRename(docs)
    
    '終わり
    Set mFSO = Nothing
    MsgBox ("Done")
    
End Sub

Private Sub ExecRename( _
    ByVal docs As Collection)
    
    Dim doc As AnyObject
    Dim tmp As Variant
    For Each doc In docs
        tmp = GetFilename_PartNum(doc)
        doc.Product.PartNumber = tmp(0)
    Next
End Sub
    
Private Function GetRenameListMsg( _
    ByVal docs As Collection) As String
    
    Dim ary() As Variant
    ReDim ary(docs.count)
    
    ary(0) = "以下のPartNumberをファイル名にします?" + vbCrLf + _
        "よろしいですか?"
        
    Dim tmp As Variant
    Dim doc As AnyObject
    Dim i As Long
    For i = 1 To docs.count
        Set doc = docs.Item(i)
        tmp = GetFilename_PartNum(doc)
        ary(i) = tmp(1) + " → " + tmp(0)
    Next
    
    GetRenameListMsg = Join(ary, vbCrLf)
        
End Function

Private Function GetFilename_PartNum( _
    ByVal doc As Document) As Variant
    
    GetFilename_PartNum = Array( _
        mFSO.GetBaseName(doc.FullName), _
        doc.Product.PartNumber)
        
End Function

Private Function GetRenameDoc( _
    ByVal docs As Collection) As Collection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim doc As AnyObject
    Dim tmp As Variant
    For Each doc In docs
        tmp = GetFilename_PartNum(doc)
        If tmp(0) <> tmp(1) Then
            Call lst.Add(doc)
        End If
    Next
    
    Set GetRenameDoc = lst
    
End Function

Private Function GetAllDoc( _
    ByVal prods As Products, _
    ByVal lst As Collection) As Collection
    
    Dim prod As Product
    For Each prod In prods
        Call lst.Add(prod.ReferenceProduct.Parent)
        Set lst = GetAllDoc(prod.Products, lst)
    Next
    
    Set GetAllDoc = lst
    
End Function