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
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先頭が0から始まる文字を数値にしないために’を入れてセルで文字列にする
If Left(rawText, 1) = "0" Or Left(rawText, 1) = "0" 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