図面の部品表をExcelファイルに保存するSolidworksのマクロ

これは、開いている図面で実行すると部品表/BOM(Bill Of Materials)をExcelファイルで保存します。Excelのファイル名は図面のファイル名と同じです。図面ファイルと同じフォルダに保存します。Excelのマクロも使ってます。

部品表のExcelファイルを移動して発注などに使っても図面の関係がわかるようにA1セルに図面ファイルのフルパスのファイル名を入れています。

完了したら、Solidworksでは完了のメッセージを開き、Windowsエクスプローラーで保存したExcelのファイルがあるフォルダを開きます。

Sub drdBOM_xls()

    ' SolidWorksアプリケーションのインスタンスを取得
    Dim swApp As SldWorks.SldWorks
    Set swApp = Application.SldWorks

    ' アクティブなドキュメントを取得
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc

    If swModel Is Nothing Then
        MsgBox "アクティブなドキュメントが見つかりません。"
        Exit Sub
    End If

    ' 部品表を保持する変数
    Dim swTable As SldWorks.TableAnnotation
    Dim foundBOM As Boolean
    foundBOM = False

    ' 図面シートまたはビューを取得し、すべてのビューを巡回
    Dim swView As SldWorks.View
    Set swView = swModel.GetFirstView

    Do While Not swView Is Nothing
        ' 各ビュー内のテーブル注釈を取得
        Dim swTableAnn As SldWorks.TableAnnotation
        Set swTableAnn = swView.GetFirstTableAnnotation

        ' テーブルアノテーションを巡回
        Do While Not swTableAnn Is Nothing
            ' 部品表かどうか確認
            If swTableAnn.Type = swTableAnnotationType_e.swTableAnnotation_BillOfMaterials Then
                Set swTable = swTableAnn
                foundBOM = True
                Exit Do
            End If
            Set swTableAnn = swTableAnn.GetNext
        Loop
        
        If foundBOM Then Exit Do
        Set swView = swView.GetNextView
    Loop

    ' 部品表が見つからなかった場合
    If Not foundBOM Then
        MsgBox "部品表が見つかりませんでした。"
        Exit Sub
    End If

    ' Excelアプリケーションのインスタンスを作成
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)

    ' Excelを表示
    xlApp.Visible = True

    ' 正規表現オブジェクトを作成してHTMLタグを削除する
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.Pattern = "<[^>]+>" ' HTMLタグにマッチするパターン

    ' 部品表の行数と列数を取得
    Dim rowCount As Long
    Dim colCount As Long
    rowCount = swTable.rowCount
    colCount = swTable.ColumnCount

    ' 部品表データをExcelに転送
    Dim i As Long, j As Long
    Dim rawText As String
    Dim cleanText As String
    For i = 0 To rowCount - 1
        For j = 0 To colCount - 1
            rawText = swTable.DisplayedText(i, j)
            '0001先頭が０から始まる文字を数値にしないために’を入れてセルで文字列にする
            If Left(rawText, 1) = "0" Or Left(rawText, 1) = "０" Then rawText = "'" & rawText
            ' HTMLタグを削除
            cleanText = regex.Replace(rawText, "")
            xlSheet.Cells(i + 1, j + 1).Value = cleanText
        Next j
    Next i
    'A1に図面のフォルダ名＋ファイル名をコメントで追加
    xlSheet.Range("A1").AddComment swModel.GetPathName
    'Excelで保存するために図面のフルパス＋ファイル名の拡張子だけを削除
    Dim ss As String
    ss = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "."))
    ss = VBA.Replace(swModel.GetPathName, ss, "")
    
    ' Excelファイルの保存
     ' 警告を無効にする
    xlApp.Application.DisplayAlerts = False
    xlBook.SaveAs ss 'Excelファイルの保存
    'xlBook.SaveAs ss & ".csv"  'CSVファイルの保存。テキストです
     ' 警告を無効にする
    xlApp.Application.DisplayAlerts = True
    xlApp.Quit  'Excel終了

    ' クリーンアップ
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

    MsgBox "部品表がExcelにエクスポートされました。"
    ' エクスプローラーでExcelで保存したフォルダを開く
    ss = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\"))
    ss = VBA.Replace(swModel.GetPathName, ss, "")
    Shell "explorer.exe " & ss, VBA.vbNormalFocus
End Sub

とりあえずの状態ですが、いずれあるフォルダ以下にある全図面ファイルの部品表を自動的にExcelファイル保存するマクロ/コードを書きたいと思います。やっぱ自動化ですよね。DX（デジタルトランスフォーメーション）っていうやつです。