カテゴリー: マクロ

フィーチャーがある時は、参照ジオメトリに「重心」と「合致参照」が増えます。背の高い製品を設計する時は重心を表示します。

フィーチャーが無いと「使えない」色になっているなら「重心」の存在を意識できるが、「平面」から「点」」までしか存在しません。Solidworksさん「重心」使えない色にして常に表示してください。

重心の位置をスケッチで使う場合、「重心参照点」をフィーチャーツリーに追加します。「重心参照点」はフィーチャーですからこれを使ってスケッチする場合は参照ジオメトリの平面を作ります。スケッチで「重心参照点」と直線の端を一致させることができます。つまり、拘束も使える。

赤い矢印が「重心参照点」フィーチャーです。

話は変わって、重心位置に点を表示するマクロです。参照ジオメトリの原点があれば十分でしょう。CharGPTならすぐできるだろうとやってみたが、部品表はすぐできたが、調子に乗っていろいろ要求したので結構時間がかかった。部品表のマクロの時は、Solidworksマクロってマイナーすぎてどうせできないだろって思って、コマメにコードを書いてもらってからまとめるという方法だったかあな。質問は１０回程度だった。いい時代です。プログラムってちょっとしたことを確認するだけで時間がかかるし、コードを書く時間も。書く手間が省けるだけですごいが、コピペで使える。

平面に平行な参照ジオメトリの平面を作って、そこに点をスケッチする。評価の質量特性で重心が一時的に表示されるので正しくスケッチされているか確認して下さい。

Option Explicit

Dim swApp As Object
Dim Part As Object
Dim MassProp As MassProperty
Dim MassCenter(2) As Double
Dim RefPlaneFeature As Object
Dim SketchMgr As Object
Dim SketchPoint As Object

Sub main()

    ' SolidWorksアプリケーションへの接続
    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
    If Part Is Nothing Then
        MsgBox "モデルが開いていません"
        Exit Sub
    End If
    
    ' 質量プロパティオブジェクトを取得
    Set MassProp = Part.Extension.CreateMassProperty
    If MassProp Is Nothing Then
        MsgBox "質量プロパティを取得できませんでした。"
        Exit Sub
    End If
    
    ' 重心の位置を取得
    MassCenter(0) = MassProp.CenterOfMass(0) ' X座標
    MassCenter(1) = MassProp.CenterOfMass(1) ' Y座標
    MassCenter(2) = MassProp.CenterOfMass(2) ' Z座標
    
    '正面を選択
    Dim boolstatus As Boolean
    boolstatus = Part.Extension.SelectByID2("正面", "PLANE", 0, 0, 0, True, 0, Nothing, 0)

    ' 平面を挿入
    Set RefPlaneFeature = Part.FeatureManager.InsertRefPlane(swRefPlaneReferenceConstraint_Distance, MassCenter(2), 0, 0, 0, 0)

    If RefPlaneFeature Is Nothing Then
        MsgBox "参照平面の作成に失敗しました。"
        Exit Sub
    End If
    
    ' スケッチマネージャーを取得
    Set SketchMgr = Part.SketchManager
    
    ' 作成した参照平面を選択
    RefPlaneFeature.Select False
    
    ' 新しいスケッチを開始
    SketchMgr.InsertSketch True
    
    ' 重心の位置に点を作成
    Set SketchPoint = SketchMgr.CreatePoint(MassCenter(0), MassCenter(1), MassCenter(2))
    
    ' スケッチを閉じる
    SketchMgr.InsertSketch True
    
    MsgBox "重心の位置を通過する参照ジオメトリ平面上に点がスケッチされました。"

End Sub

これは、開いている図面で実行すると部品表/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（デジタルトランスフォーメーション）っていうやつです。

これ、相当以前からやりたかっがやっとできた。
あるフォルダにある全図をPDFにできるようになった。うれしい。

で、
何をしてできたのかというと、googleしたのだが、
・マクロの操作を保存する方法
・ソリッドワークスのライブラリのヘルプ場所、サンプル探し
・ファイル一覧の方法
思い出せないので随時。

を押して、同じ名前でPDFファイルを保存する。（余計なこと、関係ないことをマウスで操作しないこと！！！。プログラムが煩雑になる）

以下が出来上がった。を押すとマクロのファイルを指定して呼び出すことができる。

https://forum.solidworks.com/thread/33487