材料の変更を一括して行う方法

こんにちは、

大変ご無沙汰していました。もう、夏ですね。

さて、以前に、「Inventor iProperty 編集ツール」の紹介をしましたが、何人かの方から、「材料の変更は出来ないのか？」との質問がありました。材料のプロパティは、Materialの設定を参照しているので、プロパティを変えても材料の変更はされません。また、材料を変更するファンクションは ApprenticeServerComponent には提供されていませんから、機能追加することもできません。

Inventor API を使うと可能なので、材料変更だけ手助けするマクロを作ってみました。

使い方は、簡単です。

1. Inventor iProperty 編集ツールで、変更したいモデルファイルのあるフォルダのiPropertyを表示させます。
2. Material の列を変更したい材料名に書き換えます。
3. 以下のマクロを実行します。
4. 材料が自動的に変更されます。

マクロのコードは、以下のとおり

Option Explicit
Private invApp As Inventor.Application

' Const kAsMaterialYes = True

' File Prop Editor でマテリアルを参照できるが、変更はできない。
' File Prop Editor のエクセルシートのMaterialの列を読んで、その内容でマテリアルを更新する

' 材料を変更しても、色スタイルが材料通りでないとき、表示は変更されない
' 色を材料通りにしたいときは、Const kAsMaterialYes = True を有効にする

Public Sub MaterialUpdateStart()

    On Error Resume Next

    Set invApp = ThisApplication
   
    Dim ExcelApp As Excel.Application
    Set ExcelApp = GetObject(, "Excel.Application")
   
    If Err.Number <> 0 Then
        MsgBox "FilePropEditor のエクセルファイルが見つかりません"
        Exit Sub
    End If
   
    'BOM RANGE
    Dim BOMRange As Excel.Range
    Set BOMRange = ExcelApp.Range("BOM")
   
    'Find Material column
    Dim icol As Integer
    icol = 10
    Do
        If BOMRange.Item(0, icol).Text = "Material" Then
            Exit Do
        End If
       
        If BOMRange.Item(0, icol).Text = "" Then
            icol = 0
            Exit Do
        End If

        icol = icol + 1
       
        invApp.UserInterfaceManager.DoEvents
       
    Loop
   
    If icol = 0 Then
        MsgBox "Material のプロパティ列 が見つかりません。"
        Exit Sub
    End If
   
   
    'マテリアル更新
    Dim Path As String
    Dim MaterialName As String
   
    Dim irow As Integer
    irow = 1
    Do
        Path = BOMRange.Item(irow, 6).Text
        If Path = "" Then Exit Do
       
        MaterialName = BOMRange.Item(irow, icol).Text
       
        If MaterialName <> "" Then
            MaterialUpdate Path, MaterialName
        End If
       
        irow = irow + 1
    Loop
   
    MsgBox "終了！"
   
       
End Sub

Private Sub MaterialUpdate(Path As String, MaterialName As String)

    Dim oDoc As Inventor.Document
    Dim oPartdoc As Inventor.PartDocument
    Set oDoc = invApp.Documents.Open(Path, False)
   
    If oDoc.DocumentType = kPartDocumentObject Then
        Set oPartdoc = oDoc
    Else
        oDoc.Close
        Exit Sub
    End If
   
    If oPartdoc.ComponentDefinition.Material.Name = MaterialName Then
        oPartdoc.Close
        Exit Sub
    End If
   
    On Error Resume Next
    Dim oMaterial As Inventor.Material
    Set oMaterial = oPartdoc.Materials.Item(MaterialName)
   
    If Err.Number <> 0 Or oMaterial Is Nothing Then
        oPartdoc.Close True
        Exit Sub
    Else
        oPartdoc.ComponentDefinition.Material = oMaterial
        If kAsMaterialYes Then Set oPartdoc.ActiveRenderStyle = oMaterial.RenderStyle
        oPartdoc.Save
        oPartdoc.Close True
    End If

End Sub

 参照設定で、Excel のオブジェクトライブラリを追加しておく事を忘れずに！

-YO