VBA : 서피스 이름이 있으면, 면적 가져오기

□ 소개

모델의 서피스에 이름이 있으면 이름과 함께 서피스 면적의 값을 가져오는 프로그램 입니다.

서피스 이름은 Model Properties > Name 명령을 통해  이름을 지정 할수 있습니다.▷ 코드

Option Explicit
Sub intoAssemble()
    On Error GoTo RunError
    Application.EnableEvents = False
    
    '// Check if "Program11" worksheet exists
    If Not WorksheetExists("Program02") Then
        MsgBox "Worksheet 'Program02' not found.", vbExclamation, "Error"
        Exit Sub
    End If
    
    Dim asynconn As New pfcls.CCpfcAsyncConnection
    Dim conn As pfcls.IpfcAsyncConnection
     
    '// Check Creo Connect
    Set conn = asynconn.Connect("", "", ".", 5)
    
    If conn Is Nothing Then
        MsgBox "An error occurred while starting a new Creo Parametric Session", vbInformation, "www.idt21c.com"
        Exit Sub
    End If
    
    Dim BaseSession As pfcls.IpfcBaseSession
    Dim Session As IpfcSession
    Dim model As pfcls.IpfcModel
    Dim Solid As IpfcSolid
    
    '// Current Model Information
    Set BaseSession = conn.Session
    Set model = BaseSession.CurrentModel
    Set Solid = model
    
    Worksheets("Program01").Cells(2, "D") = BaseSession.GetCurrentDirectory
    Worksheets("Program01").Cells(3, "D") = model.filename
    
    Dim ModelItemOwner As IpfcModelItemOwner
    Dim ModelItems As IpfcModelItems
    Dim ModelItem As IpfcModelItem
    Dim Surface As IpfcSurface
    
    Set ModelItemOwner = model
    Set ModelItems = ModelItemOwner.ListItems(EpfcModelItemType.EpfcITEM_SURFACE)
    
    Dim i As Long
    For i = 0 To ModelItems.Count - 1
        Set ModelItem = ModelItems.item(i)
       
        If ModelItem.GetName <> "" Then
             Cells(i + 5, "B") = ModelItem.GetName
             Set Surface = ModelItem
             Cells(i + 5, "C") = Surface.EvalArea
         End If
     Next i
    
    conn.Disconnect (2)
    
    ' Cleanup
    Set asynconn = Nothing
    Set conn = Nothing
    Set BaseSession = Nothing
    Set model = Nothing
    
Exit Sub

RunError:
    If Err.Number <> 0 Then
        MsgBox "Process Failed: An error occurred." & vbCrLf & _
               "Error No: " & CStr(Err.Number) & vbCrLf & _
               "Error Description: " & Err.Description & vbCrLf & _
               "Error Source: " & Err.Source, vbCritical, "Error"
        If Not conn Is Nothing Then
            If conn.IsRunning Then
                conn.Disconnect (2)
            End If
        End If
    End If
End Sub

Function WorksheetExists(shtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not Worksheets(shtName) Is Nothing
    On Error GoTo 0
End Function

---

영업문의 : lionkk@idt21c.com
카카오 채널 : http://pf.kakao.com/_fItAxb