SOLIDWORKS API Excel VBA 「寸法取得と変更マクロ」

あじろのブログⅡ
SOLIDWORKS API 覚書その28 EXCELで寸法取得とか変更するマクロ
の簡易版マクロを作成！仕様は↓
・SOLIDWORKS上で寸法を選択 → 取得
・Excelで変更値を入力 → 変更
・Excelで寸法名を選択 → SOLIDWORKSで選択

YouTubeでは3回に分けて作成。Excel連携の入門用にどうぞ！

Sub main()

Dim swApp As SldWorks.SldWorks
Dim swDoc As ModelDoc2

Dim swDim As Dimension

On Error Resume Next

Set swApp = GetObject(, "SldWorks.Application")
If swApp Is Nothing Then Exit Sub

Set swDoc = swApp.ActiveDoc
If swDoc Is Nothing Then Exit Sub

Dim maxrow As Long
maxrow = Cells(Rows.Count, 1).End(xlUp).Row

If maxrow < 3 Then Exit Sub

Range(Cells(3, 2), Cells(maxrow, 3)).ClearContents

Dim i As Long
For i = 3 To maxrow
    Set swDim = swDoc.Parameter(Cells(i, 1))
    If Not swDim Is Nothing Then
        Cells(i, 2) = swDim.Value
    End If
Next i

End Sub


Sub ChgDim()

Dim swApp As SldWorks.SldWorks
Dim swDoc As ModelDoc2

Dim swDim As Dimension

On Error Resume Next

Set swApp = GetObject(, "SldWorks.Application")
If swApp Is Nothing Then Exit Sub

Set swDoc = swApp.ActiveDoc
If swDoc Is Nothing Then Exit Sub

Dim maxrow As Long
maxrow = Cells(Rows.Count, 1).End(xlUp).Row

If maxrow < 3 Then Exit Sub

Dim i As Long
For i = 3 To maxrow
    Set swDim = swDoc.Parameter(Cells(i, 1))
    If Not swDim Is Nothing Then
        If Cells(i, 3) <> "" And IsNumeric(Cells(i, 3)) Then
            swDim.Value = Cells(i, 3)
        End If
    End If
Next i

swDoc.ForceRebuild3 (True)

End Sub

※1/3では
1.寸法名をセルに手入力
2.マクロで寸法値を取得
3.セルに変更後の寸法値を入力
4.2.マクロで寸法値を変更、更新

Public swApp As SldWorks.SldWorks
Public swDoc As ModelDoc2

Dim swDim As Dimension

Dim maxrow As Long

Sub main()

On Error Resume Next

If ConnSW = False Then Exit Sub

Range(Cells(3, 2), Cells(maxrow, 3)).ClearContents

Dim i As Long
For i = 3 To maxrow
    Set swDim = swDoc.Parameter(Cells(i, 1))
    If Not swDim Is Nothing Then
        Cells(i, 2) = swDim.Value
    End If
Next i

End Sub


Sub ChgDim()

On Error Resume Next

If ConnSW = False Then Exit Sub

Dim i As Long
For i = 3 To maxrow
    Set swDim = swDoc.Parameter(Cells(i, 1))
    If Not swDim Is Nothing Then
        If Cells(i, 3) <> "" And IsNumeric(Cells(i, 3)) Then
            swDim.Value = Cells(i, 3)
        End If
    End If
Next i

swDoc.ForceRebuild3 (True)

End Sub

Function ConnSW() As Boolean

Set swApp = GetObject(, "SldWorks.Application")
If swApp Is Nothing Then Exit Function

Set swDoc = swApp.ActiveDoc
If swDoc Is Nothing Then Exit Function

maxrow = Cells(Rows.Count, 1).End(xlUp).Row

If maxrow < 3 Then Exit Function

ConnSW = True

End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim boolstatus As Boolean

On Error Resume Next

If Target.Count <> 1 Then Exit Sub
If Target.Text = "" Then Exit Sub

If ConnSW = False Then Exit Sub

swDoc.ClearSelection2 (True)

Dim selRow As Long
Dim selCol As Long

selRow = Target.Row
selCol = Target.Column

If selCol = 1 Then
    boolstatus = swDoc.Extension.SelectByID2(Cells(selRow, 1), "DIMENSION", 0, 0, 0, False, 0, Nothing, 0)
End If

End Sub

※2/3では
1.セルで寸法名を選択するとSOLIDWORKSで表示される
2.コードのモジュール化

Public swApp As SldWorks.SldWorks
Public swDoc As ModelDoc2

Dim swDim As Dimension

Dim maxrow As Long

Sub main()

On Error Resume Next

If ConnSW = False Then Exit Sub

Dim swSelMgr As SelectionMgr
Set swSelMgr = swDoc.SelectionManager

If swSelMgr.GetSelectedObjectCount2(-1) = 0 Then Exit Sub

Dim swDispDim As DisplayDimension

Dim i As Long
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
    If swSelMgr.GetSelectedObjectType3(i, -1) = 14 Then
        Set swDispDim = swSelMgr.GetSelectedObject6(i, -1)
        Cells(maxrow + i, 1) = swDispDim.GetNameForSelection
        Set swDim = swDispDim.GetDimension
        Cells(maxrow + i, 2) = swDim.Value
    End If
Next i

End Sub

Sub ChgDim()

On Error Resume Next

If ConnSW = False Then Exit Sub

Dim i As Long
For i = 3 To maxrow
    Set swDim = swDoc.Parameter(Cells(i, 1))
    If Not swDim Is Nothing Then
        If Cells(i, 3) <> "" And IsNumeric(Cells(i, 3)) Then
            swDim.Value = Cells(i, 3)
        End If
    End If
Next i

swDoc.ForceRebuild3 (True)

End Sub

Function ConnSW() As Boolean

Set swApp = GetObject(, "SldWorks.Application")
If swApp Is Nothing Then Exit Function

Set swDoc = swApp.ActiveDoc
If swDoc Is Nothing Then Exit Function

maxrow = Cells(Rows.Count, 1).End(xlUp).Row

ConnSW = True

End Function

Sub clear()

maxrow = Cells(Rows.Count, 1).End(xlUp).Row

If maxrow > 2 Then
    Range(Cells(3, 2), Cells(maxrow, 3)).ClearContents
End If

End Sub

※3/3では
1.SOLIDWORKSで選択した寸法の寸法名と値を取得
2.ついでにクリアボタンも追加