모델의 Feature Name, Type, ID 및 Dimensions Name, value 가져오기

 

Code

Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim WS As Worksheet
Dim rowIndex As Long

Sub ExportToExcel()
    On Error Resume Next
    Set WS = ThisWorkbook.Worksheets("Model01")
    Set swApp = GetObject(, "SldWorks.Application")
    On Error GoTo 0
    
    If swApp Is Nothing Then
        MsgBox "SOLIDWORKS를 찾을 수 없습니다. 실행 중인지 확인하세요.", vbCritical
        Exit Sub
    End If

    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "활성화된 문서를 찾을 수 없습니다. 문서를 열고 다시 시도하세요.", vbCritical
        Exit Sub
    End If
    
    WS.Cells(8, "C").Value = swModel.GetTitle

    Set swFeat = swModel.FirstFeature
    rowIndex = 10 ' 데이터가 시작될 행

    Do While Not swFeat Is Nothing
        Dim swDispDim As SldWorks.DisplayDimension
        Dim swDim As SldWorks.Dimension
        Dim dimIndex As Long

        dimIndex = 0
        Set swDispDim = swFeat.GetFirstDisplayDimension()

        ' Feature에 치수가 없을 경우 Feature 정보만 출력
        If swDispDim Is Nothing Then
            WS.Cells(rowIndex, "A").Value = rowIndex - 9
            WS.Cells(rowIndex, "B").Value = swFeat.Name
            WS.Cells(rowIndex, "C").Value = swFeat.GetTypeName2()
            WS.Cells(rowIndex, "D").Value = swFeat.GetID()
            rowIndex = rowIndex + 1
        Else
            Do While Not swDispDim Is Nothing
                Set swDim = swDispDim.GetDimension()
                If Not swDim Is Nothing Then
                    WS.Cells(rowIndex, "A").Value = rowIndex - 9
                    WS.Cells(rowIndex, "B").Value = swFeat.Name
                    WS.Cells(rowIndex, "C").Value = swFeat.GetTypeName2()
                    WS.Cells(rowIndex, "D").Value = swFeat.GetID()
                    WS.Cells(rowIndex, "E").Value = swDim.FullName
                    WS.Cells(rowIndex, "F").Value = swDim.Value
                    rowIndex = rowIndex + 1
                    dimIndex = dimIndex + 1
                End If
                Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
            Loop
        End If
        Set swFeat = swFeat.GetNextFeature
    Loop

    MsgBox "SOLIDWORKS 모델 데이터가 Excel로 내보내졌습니다.", vbInformation
End Sub

' Feature의 치수값 가져오기
Function GetFeatureDimensions(feat As SldWorks.Feature) As String
    Dim swDispDim As SldWorks.DisplayDimension
    Dim dimString As String
    dimString = ""

    ' Feature 내부 치수 확인
    Set swDispDim = feat.GetFirstDisplayDimension()
    Do While Not swDispDim Is Nothing
        Dim swDim As SldWorks.Dimension
        Set swDim = swDispDim.GetDimension()
        If Not swDim Is Nothing Then
            If dimString <> "" Then dimString = dimString & "; "
            dimString = dimString & swDim.FullName & "=" & swDim.Value
        End If
        Set swDispDim = feat.GetNextDisplayDimension(swDispDim)
    Loop

    GetFeatureDimensions = dimString
End Function